C***********************************************************************
C* February 1997                                                       *
C*                       Program PARS9396                              *
C*                                                                     *
C*                         by M.NARDELLI                               *
C* Dipartimento di Chimica Generale ed Inorganica, Chimica Analitica,  *
C* Chimica Fisica della Universita` degli Studi di Parma, Centro di    *
C* Studio per la Strutturistica Diffrattometrica del C.N.R., Viale     *
C* delle Scienze, I-43100 Parama, Italy.                               *
C*                                                                     *
C* This program creates the input file for PARST96 (atom labels 6A1)   *
C* from the input file of PARST93 (atom labels 4A1)                    *
C*                                                                     *
C***********************************************************************
      PROGRAM PARS9396
      CHARACTER*1 TIT(80),SDOL(6,500),TIT1(120),LA1(2,20),PDOL(6,40),
     1 UNIM(3,5),II(5),SBL(6,200),SL(6,4)
      CHARACTER*2 LA(20)
      CHARACTER*80 FRT
      DIMENSION FST(20)
      DIMENSION C(3),SC(3),A(3),SA(3),V(3,500),S(3,500),B(6,500),
     1 SB(6,500)
      EQUIVALENCE(LA(1),LA1(1,1))
      COMMON/INPOU/IN,IO
      IN=13
      IO=15
      CALL INPOUT
      OPEN(UNIT=10,FORM='FORMATTED',STATUS='SCRATCH')
      DO 25 I=1,500
      DO 25 J=1,6
25    SDOL(J,I)=' '
C-----Title
      READ(IN,'(80A1)')TIT
      WRITE(IO,'(80A1)')TIT
C-----Bravais symbol
      READ(IN,'(80A1)')TIT
      WRITE(IO,'(80A1)')TIT
C-----Codes
      READ(IN,*)N,D3,DM,NH1,NTN,LSP,LSL,NPR,NST,KL,KY,KC,KO,KB,KA,KT,
     1 KD,KE,KOR,NI
      KL1=1
      WRITE(10,'(I3,2('','',F4.2),6('','',I2),11('','',I1))')N,D3,DM,
     1 NH1,NTN,LSP,LSL,NPR,NST,KL1,KY,KC,KO,KB,KA,KT,KD,KE,KOR,NI
      BACKSPACE 10
      READ(10,'(80A1)')TIT
      CALL SETS(TIT)
      WRITE(IO,'(80A1)')TIT
C-----Atomic species, number of molecules and lambda
      IF(KY.NE.0)THEN
      READ(IN,*)NA,IZ,ALA
      WRITE(10,'(I2,'','',I4,'','',F8.5)')NA,IZ,ALA
      BACKSPACE 10
      READ(10,'(80A1)')TIT
      CALL SETS(TIT)
      WRITE(IO,'(80A1)')TIT
      READ(IN,*)(LA(I),FST(I),I=1,NA)
      CALL STRAT(NA,LA1,FST,TIT1)
      WRITE(IO,'(120A1)')TIT1
      ENDIF
C-----Cell constants
      READ(IN,*)C,SC,A,SA
      WRITE(IO,'(3(F8.4,1X),3(F5.4,1X),3(F6.2,1X),3(F3.2,1X))')
     1 C,SC,A,SA
C-----Write the FORMAT of coordinates
      IF(KOR.EQ.0)THEN
      WRITE(IO,'(''(6A1,6F9.5)'')')
      ELSE
      WRITE(IO,100)
100   FORMAT('(6A1,6F9.5/6F9.5/6F9.5)')
      ENDIF
C-----Read atom symbols,coordinates,thermal parameters & e.s.d.'s
      IF(KL.EQ.4) GO TO 12
      READ(IN,'(A80)')FRT
      IF(KOR.EQ.0) GO TO 1
      GO TO (2,4,6),KL
1     GO TO (8,8,10,12),KL
2     DO 3 J=1,N
3     READ(IN,FRT)(SDOL(L,J),L=1,4),(V(I,J),I=1,3),(S(I,J),I=1,3),
     1 (B(I,J),I=1,6),(SB(I,J),I=1,6)
      GO TO 15
4     DO 5 J=1,N
5     READ(IN,FRT)(SDOL(L,J),L=1,4),(V(I,J),I=1,3),(B(I,J),I=1,6),
     1 (S(I,J),I=1,3),(SB(I,J),I=1,6)
      GO TO 15
6     DO 7 J=1,N
7     READ(IN,FRT)(SDOL(L,J),L=1,4),(V(I,J),S(I,J),I=1,3),
     1 (B(I,J),SB(I,J),I=1,6)
      GO TO 15
8     DO 9 J=1,N
9     READ(IN,FRT)(SDOL(L,J),L=1,4),(V(I,J),I=1,3),(S(I,J),I=1,3)
      GO TO 15
10    DO 11 J=1,N
11    READ(IN,FRT)(SDOL(L,J),L=1,4),(V(I,J),S(I,J),I=1,3)
      GO TO 15
12    DO 14 J=1,N
      READ(IN,'(7X,6A1,2X,3F8.5,12X,3(5A1,3X))')(SDOL(L,J),L=1,4),
     1 (V(I,J),I=1,3),((UNIM(I,K),K=1,5),I=1,3)
      DO 14 I=1,3
      DO 13 JJ=1,5
13    II(JJ)=UNIM(I,JJ)
      CALL CONVE(II,DH)
14    S(I,J)=DH
C-----Write atomic coordinates and displacement parameters
15    DO 16 I=1,N
      IF(KOR.EQ.0)THEN
      WRITE(IO,'(6A1,6F9.5)')(SDOL(L,I),L=1,6),(V(K,I),K=1,3),
     1 (S(K,I),K=1,3)
      ELSE
      WRITE(IO,'(6A1,6F9.5/6F9.5/6F9.5)')(SDOL(L,I),L=1,6),
     1 (V(K,I),K=1,3),(S(K,I),K=1,3),(B(K,I),K=1,6),(SB(K,I),K=1,6)
      ENDIF
16    CONTINUE
C-----Calculated hydrogens
      IF(NH1.NE.0)THEN
      DO 23 I=1,NH1
      READ(IN,'(I1,1X,F6.4,4(4A1))')KDG,D,((SL(L,K),L=1,4),K=1,4)
      CALL BLK(4,SL)
23    WRITE(IO,'(I1,1X,F6.4,4(6A1))')KDG,D,((SL(L,K),L=1,6),K=1,4)
      ENDIF
C-----Torsion angles formed by non bonded atoms
      IF(NTN.NE.0)THEN
      DO 24 I=1,NTN
      READ(IN,'(4(4A1))')((SL(L,K),L=1,4),K=1,4)
      CALL BLK(4,SL)
24    WRITE(IO,'(4(6A1))')((SL(L,K),L=1,6),K=1,4)
      ENDIF
C-----Least-squares planes
      IF(LSP.NE.0)THEN
      DO 17 III=1,LSP
      READ(IN,'(2I2,4X,16(4A1)/18(4A1))')NT,NFP,
     1 ((PDOL(L,J),L=1,4),J=1,NT)
      CALL BLK(NT,PDOL)
      IF(NT.LE.12)THEN
      WRITE(IO,'(2I2,4X,12(6A1))')NT,NFP,((PDOL(L,J),L=1,6),J=1,NT)
      ELSE
      WRITE(IO,'(2I2,4X,12(6A1)/12(6A1))')NT,NFP,
     1 ((PDOL(L,J),L=1,6),J=1,NT)
      ENDIF
17    CONTINUE
      ENDIF
C-----Least-squares lines
      IF(LSL.NE.0)THEN
      DO 18 III=1,LSL
      READ(IN,'(2I2,4X,16(4A1)/18(4A1))')NT,NFP,
     1 ((PDOL(L,J),L=1,4),J=1,NT)
      CALL BLK(NT,PDOL)
18    WRITE(IO,'(2I2,4X,12(6A1)/12(6A1))')NT,NFP,
     1 ((PDOL(L,J),L=1,6),J=1,NT)
      ENDIF
C-----Ring puckering coordinates
      IF(NPR.NE.0)THEN
      DO 19 I=1,NPR
      READ(IN,'(I2,6X,16(4A1)/18(4A1))')NT,
     1 ((PDOL(L,J),L=1,4),J=1,NT)
      CALL BLK(NT,PDOL)
19    WRITE(IO,'(I2,6X,12(6A1)/12(6A1))')NT,
     1 ((PDOL(L,J),L=1,6),J=1,NT)
      ENDIF
C-----Polar coordinates of atomic environments
      IF(NPR.NE.0)THEN
      DO 20 I=1,NST
      READ(IN,'(I1,2I2,3X,16(4A1)/18(4A1))')K0,NP,NQ,
     1 ((PDOL(L,J),L=1,4),J=1,NP)
      CALL BLK(NP,PDOL)
20    WRITE(IO,'(I1,2I2,3X,12(6A1)/12(6A1))')K0,NP,NQ,
     1 ((PDOL(L,J),L=1,6),J=1,NP)
      ENDIF
C-----Equivalent positions
      READ(IN,*)IC,NE,NT
      WRITE(10,'(I2,'','',I3,'','',I1)')IC,NE,NT
      BACKSPACE 10
      READ(10,'(80A1)')TIT
      CALL SETS(TIT)
      WRITE(IO,'(80A1)')TIT
      IF(NE.NE.0)THEN
      DO 21 I=1,NE
      READ(IN,'(80A1)')TIT
21    WRITE(IO,'(80A1)')TIT
      ENDIF
C-----Comparison of atomic subsets
      IF(NI.NE.0)THEN
      DO 22 J=1,NI
      READ(IN,*)N
      WRITE(IO,'(I3)')N
      READ(IN,'(72A1)')((SBL(L,I),L=1,4),I=1,N)
      CALL BLK(N,SBL)
      WRITE(IO,'(72A1)')((SBL(L,I),L=1,6),I=1,N)
22    CONTINUE
      ENDIF
      CLOSE (IN)
      CLOSE (IO)
      STOP
      END
 
      SUBROUTINE INPOUT
C-----Assignes the input and output files
      CHARACTER*10 STR1
      CHARACTER*8,STR2
      CHARACTER*14 FILIN
      COMMON/INPOU/IN,IO
      STR1='Key in the'
      STR2='put file'
      WRITE(*,'(1X,A10,'' in'',A8/'' ?>'')')STR1,STR2
      READ(*,'(A14)')FILIN
      OPEN(UNIT=IN,FILE=FILIN,FORM='FORMATTED')
      REWIND(UNIT=IN)
      WRITE(*,'(1X,A10,'' out'',A8/'' ?>'')')STR1,STR2
      READ(*,'(A14)')FILIN
      OPEN(UNIT=IO,FILE=FILIN,FORM='FORMATTED')
      REWIND(UNIT=IO)
      RETURN
      END
 
      SUBROUTINE CONVE(II,DX)
      DIMENSION IX(5)
      CHARACTER*1 II(5),IA(10)
      DATA IA/'0','1','2','3','4','5','6','7','8','9'/
      DO 2 I=1,5
      IX(I)=0
      DO 3 K=1,10
      IF(IA(K).EQ.II(I)) GO TO 1
3     CONTINUE
1     IX(I)=K-1
2     CONTINUE
      IF(II(5).NE.' ') DX=IX(1)*0.1+IX(2)*0.01+IX(3)*0.001+
     1 IX(4)*0.0001+IX(5)*0.00001
      IF(II(5).EQ.' ') DX=IX(1)*0.01+IX(2)*0.001+IX(3)*0.0001+
     1 IX(4)*0.00001
      IF(II(4).EQ.' ') DX=IX(1)*0.001+IX(2)*0.0001+IX(3)*0.00001
      IF(II(3).EQ.' ') DX=IX(1)*0.0001+IX(2)*0.00001
      IF(II(2).EQ.' ') DX=IX(1)*0.00001
      IF(II(1).EQ.' ') DX=0.0
      RETURN
      END
 
      SUBROUTINE STRAT(NA,STRA,FST,TIT1)
C-----ENCODES in a string the atom symbols and their numbers
      CHARACTER*1 TIT1(120),STRA(2,20)
      DIMENSION FST(20)
      WRITE(10,100)((STRA(L,I),L=1,2),FST(I),I=1,NA)
100   FORMAT(20('''',2A1,'''',',',F7.3,','))
      BACKSPACE 10
      READ(10,'(120A1)')TIT1
      DO 2 I=1,116
      IF(TIT1(I).EQ.'.'.AND.TIT1(I+1).EQ.'0'.AND.TIT1(I+2).EQ.'0'.AND.
     1 TIT1(I+3).EQ.'0')THEN
      DO 1 K=1,4
1     TIT1(I+K-1)=' '
      ENDIF
      IF(TIT1(I).EQ.','.AND.TIT1(I+1).EQ.''''.AND.TIT1(I+2).EQ.' '.
     1 AND.TIT1(I+3).EQ.' '.AND.TIT1(I+4).EQ.' ')THEN
      TIT1(I)=' '
      TIT1(I+1)=' '
      ENDIF
2     CONTINUE
      DO 4 K=1,10
      DO 4 I=2,119
      IF(TIT1(I).EQ.' '.AND.TIT1(I+1).NE.'''')THEN
      TIT1(119)=' '
      DO 3  J=I,119
3     TIT1(J)=TIT1(J+1)
      ENDIF
4     CONTINUE
      RETURN
      END
 
      SUBROUTINE SETS(TIT)
C-----Eliminates redundant blanks in a string
      CHARACTER*1 TIT(80)
      DO 2 K=1,3
      IF(TIT(1).EQ.' ')THEN
      DO 1 J=1,79
1     TIT(J)=TIT(J+1)
      ENDIF
2     CONTINUE
      DO 4 K=1,5
      DO 4 I=1,78
      IF(TIT(I).EQ.','.AND.TIT(I+1).EQ.' ')THEN
      DO 3 J=I,78
3     TIT(J+1)=TIT(J+2)
      ENDIF
4     CONTINUE
      RETURN
      END
 
      SUBROUTINE BLK(N,SL)
C-----Blanks two characters in N six-character-strings
      CHARACTER*1 SL(6,N)
      DO 1 K=1,N
      DO 1 L=5,6
1     SL(L,K)=' '
      RETURN
      END
