! Translate the basis of the supercell
      PROGRAM TRANSLATE
      USE prec

      IMPLICIT NONE

      CHARACTER*1  C
      CHARACTER*80 LINE,CHWORK,CHTEMP,FORM
      LOGICAL      L(3),LS
      INTEGER      NTYP,ITYP,NIONS,NIONIN,NEMPTY,LL,LLINE,LENGTH,NITEMS
      INTEGER, ALLOCATABLE :: NI(:)
      REAL(q)      A(3,3),B(3,3),X(3),Y(3),DX,DY,DZ,SCALE

      EXTERNAL LENGTH,NITEMS

! get parameters and header of file POSOLD
      NIONS=0
      NEMPTY=0
      WRITE(*,*) 'DX,DY,DZ (use same coordinate type as on POSOLD!)?'
      READ(*,*) DX,DY,DZ
      WRITE(*,*) 'Reading from POSOLD and writing to POSNEW.'
      OPEN(20,FILE='POSOLD',STATUS='OLD',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)
      WRITE(21,'(3F20.14)') A(1,1),A(2,1),A(3,1)
      READ(20,*,ERR=200,END=200) A(1,2),A(2,2),A(3,2)
      WRITE(21,'(3F20.14)') A(1,2),A(2,2),A(3,2)
      READ(20,*,ERR=200,END=200) A(1,3),A(2,3),A(3,3)
      WRITE(21,'(3F20.14)') A(1,3),A(2,3),A(3,3)
      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 10 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)
            NIONIN = NIONIN + NI(ITYP)
         ENDIF
   10 CONTINUE
      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
      IF ((C=='C') .OR. (C=='c') .OR. (C=='K') .OR. (C=='k')) THEN
         Y(1) = DX*B(1,1) + DY*B(2,1) + DZ*B(3,1)
         Y(2) = DX*B(1,2) + DY*B(2,2) + DZ*B(3,2)
         Y(3) = DX*B(1,3) + DY*B(2,3) + DZ*B(3,3)
         DX   = Y(1)
         DY   = Y(2)
         DZ   = Y(3)
      ENDIF
      WRITE(21,'(A)') 'Direct'

! main loop (implicit) reading and writing all coordinates
   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)+DX,X(2)+DY,X(3)+DZ,L(1),L(2),L(3)
      ELSE
         WRITE(21,'(3F20.14)') X(1)+DX,X(2)+DY,X(3)+DZ
      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
         NTYP  = NITEMS(LINE,CHWORK,.TRUE.,'I')
         DEALLOCATE(NI)
         ALLOCATE(NI(NTYP))
         DO 30 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
   30    CONTINUE
         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.EQ.(NEMPTY+NIONIN)) GOTO 100
      GOTO 20

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

  100 CONTINUE
      END