! Redimension a surface supercell or a cell containing a molecule
      PROGRAM REDIM
      USE prec

      IMPLICIT NONE

      CHARACTER*1  C
      CHARACTER*80 LINE,CHWORK,CHTEMP,FORM
      LOGICAL      L(3),LS
      INTEGER      NIONS,NEMPTY,NIONIN,NTYP,ITYP,LLINE,LL,LENGTH,NITEMS
      REAL(q)      XDIM,YDIM,ZDIM,XSCALE,YSCALE,ZSCALE,A1LEN,A2LEN,A3LEN,SCALE
      REAL(q)      A(3,3),B(3,3),X(3),Y(3)
      INTEGER, ALLOCATABLE :: NI(:)

      EXTERNAL LENGTH,NITEMS

! get parameters and header of POSOLD
      NIONS  = 0
      NEMPTY = 0
      WRITE(*,*) 'XDIM,YDIM,ZDIM (mapped to XSCALE,YSCALE,ZSCALE if < 0)?'
      READ(*,*) XDIM,YDIM,ZDIM
      WRITE(*,*) 'Reading from POSOLD and writing to POSNEW.'
      OPEN(20,FILE='POSOLD',ERR=200)
      OPEN(21,FILE='POSNEW',ERR=200)
      READ(20,'(A)',ERR=200,END=200) LINE
      LLINE  = LENGTH(LINE)
      WRITE(21,'(A)') LINE(1:LLINE)
      READ(20,*,ERR=200,END=200) SCALE
      WRITE(21,'(F20.14)') SCALE
      READ(20,*,ERR=200,END=200) A(1,1),A(2,1),A(3,1)
      IF (XDIM > 0._q) THEN
         A1LEN  = SQRT(A(1,1)*A(1,1)+A(2,1)*A(2,1)+A(3,1)*A(3,1))
         XSCALE = XDIM/A1LEN
      ELSE
         XSCALE = -XDIM
      ENDIF
      WRITE(21,'(3F20.14)') A(1,1)*XSCALE,A(2,1)*XSCALE,A(3,1)*XSCALE
      READ(20,*,ERR=200,END=200) A(1,2),A(2,2),A(3,2)
      IF (YDIM > 0._q) THEN
         A2LEN  = SQRT(A(1,2)*A(1,2)+A(2,2)*A(2,2)+A(3,2)*A(3,2))
         YSCALE = YDIM/A2LEN
      ELSE
         YSCALE = -YDIM
      ENDIF
      WRITE(21,'(3F20.14)') A(1,2)*YSCALE,A(2,2)*YSCALE,A(3,2)*YSCALE
      READ(20,*,ERR=200,END=200) A(1,3),A(2,3),A(3,3)
      IF (ZDIM > 0._q) THEN
         A3LEN  = SQRT(A(1,3)*A(1,3)+A(2,3)*A(2,3)+A(3,3)*A(3,3))
         ZSCALE = ZDIM/A3LEN
      ELSE
         ZSCALE = -ZDIM
      ENDIF
      WRITE(21,'(3F20.14)') A(1,3)*ZSCALE,A(2,3)*ZSCALE,A(3,3)*ZSCALE
      CALL RECIPS(1._q,A(1,1),A(1,2),A(1,3),B(1,1),B(1,2),B(1,3))
      READ(20,'(A)',ERR=200,END=200) LINE
      NTYP   = NITEMS(LINE,CHWORK,.TRUE.,'I')
      ALLOCATE(NI(NTYP))
      NIONIN = 0
      DO ITYP=1,NTYP
         CALL SUBWRD(LINE,CHTEMP,ITYP,1)
         CALL CHKINT(CHTEMP,CHWORK,C,FORM)
         IF ((C.NE.'N').AND.(C.NE.'U')) THEN
            CHWORK = '('//FORM(1:72)//')'
            CALL STRIP(CHWORK,LL,'A')
            READ(CHTEMP,CHWORK) NI(ITYP)
            NIONIN = NIONIN + NI(ITYP)
         ENDIF
      ENDDO
      WRITE(FORM,'(A,I5,A)') '(',NTYP,'I5)'
      CALL STRIP(FORM,LL,'A')
      WRITE(21,FORM) (NI(ITYP),ITYP=1,NTYP)
      READ(20,'(A1)',ERR=200,END=200) C
      LS=((C=='S') .OR. (C=='s'))
      IF (LS) THEN
         WRITE(21,'(A)') 'Selective dynamics'
         READ(20,'(A1)',ERR=200,END=200) C
      ENDIF
      WRITE(21,'(A)') 'Direct'

! main loop (implicit) for reading/writing all ionic positions
   20 CONTINUE
      IF (LS) THEN
         READ(20,*,ERR=200,END=200) X(1),X(2),X(3),L(1),L(2),L(3)
      ELSE
         READ(20,*,ERR=200,END=200) X(1),X(2),X(3)
      ENDIF
      IF ((C=='C') .OR. (C=='c') .OR. (C=='K') .OR. (C=='k')) THEN
         Y(1) = X(1)*B(1,1) + X(2)*B(2,1) + X(3)*B(3,1)
         Y(2) = X(1)*B(1,2) + X(2)*B(2,2) + X(3)*B(3,2)
         Y(3) = X(1)*B(1,3) + X(2)*B(2,3) + X(3)*B(3,3)
         X(1) = Y(1)
         X(2) = Y(2)
         X(3) = Y(3)
      ENDIF
      IF (LS) THEN
         WRITE(21,'(3F20.14,3L4)') X(1)/XSCALE,X(2)/YSCALE, &
                                   X(3)/ZSCALE,L(1),L(2),L(3)
      ELSE
         WRITE(21,'(3F20.14)') X(1)/XSCALE,X(2)/YSCALE,X(3)/ZSCALE
      ENDIF
      NIONS = NIONS + 1
      IF (NIONS==NIONIN) THEN
         READ(20,'(A)',ERR=100,END=100) LINE
         IF ((LINE(1:1)/='E').AND.(LINE(1:1)/='e')) GOTO 100
         LLINE = LENGTH(LINE)
         WRITE(21,'(A)') LINE(1:LLINE)
         READ(20,'(A)',ERR=200,END=200) LINE
         DEALLOCATE(NI)
         NTYP  = NITEMS(LINE,CHWORK,.TRUE.,'I')
         ALLOCATE(NI(NTYP))
         DO ITYP=1,NTYP
            CALL SUBWRD(LINE,CHTEMP,ITYP,1)
            CALL CHKINT(CHTEMP,CHWORK,C,FORM)
            IF ((C/='N').AND.(C/='U')) THEN
               CHWORK = '('//FORM(1:72)//')'
               CALL STRIP(CHWORK,LL,'A')
               READ(CHTEMP,CHWORK) NI(ITYP)
               NEMPTY = NEMPTY + NI(ITYP)
            ENDIF
         ENDDO
         WRITE(FORM,'(A,I5,A)') '(',NTYP,'I5)'
         CALL STRIP(FORM,LL,'A')
         WRITE(21,FORM) (NI(ITYP),ITYP=1,NTYP)
         LS = .FALSE.
      ENDIF
      IF (NIONS==(NEMPTY+NIONIN)) GOTO 100
      GOTO 20

  200 CONTINUE
      WRITE(*,*) 'Error reading or opening file POSOLD.'
      STOP

  100 CONTINUE
      END