C***********************************************************************
C* Release February 1997                                               *
C*                          PARSTINS                                   *
C*                    by Mario Nardelli                                *
C* Dipartimento di Chimica Generale ed Inorganica, Chimica Analitica,  *
C* Chimica Fisica della Universita' degli Studi di Parma, Centro di    *
C* Studio CNR per la Strutturistica Diffratometrica,                   *
C* Viale delle Scienze 78, I-43100 PARMA, Italy.                       *
C*                                                                     *
C* This routine allows to get the file input for SHELXL-93 from the    *
C* file input of PARST.                                                *
C* N.B.- If KY=0 the wavelength is missing (given as 0.00000)          *
C*       Some editing and checking of the file could be necessary.     *
C*                                                                     *
C* SUBROUTINES:                                                        *
C*             INPOUT                                                  *
C*             CONVE                                                   *
C*             MINUMA                                                  *
C*             LABL                                                    *
C*             ATOMLABL                                                *
C*             BLOCK DATA                                              *
C***********************************************************************
      PROGRAM PARSTINS
      CHARACTER*1 BRV,TIT(80),SDOL(6,500),LA1(2,20),MINUS(2),LTP(7),
     1 UNIM(3,5),II(5),ATOM(2),STR(20),AAAA(6),LBA(2),SDL1(2,500)
      CHARACTER*2 LA(20),KS,SDL2(500)
      CHARACTER*80 FRT
      DIMENSION C(3),SC(3),A(3),SA(3),V(3,500),ANAA(20),S(3,500),
     1 INA(20),B(6,500),SB(6,500)
      COMMON/GRG1/SDL2
     1      /GRG2/LA
     2      /GRG3/N,INA,NNS
     3      /INPOU/IN,IO
      EQUIVALENCE (LA(1),LA1(1,1)),(SDL2(1),SDL1(1,1))
      DATA LTP /'P','I','R','F','A','B','C'/
      IN=13
      IO=15
      CALL INPOUT
C-----Read title, codes and parameters
      READ(IN,'(80A1)') TIT
      WRITE(IO,'(''TITL '',80A1)') TIT
      READ(IN,'(A1)') BRV
      KK=1
      DO 1 I=1,7
      IF(BRV.EQ.LTP(I))THEN
      KK=I
      GO TO 2
      ENDIF
1     CONTINUE
      WRITE(IO,100) BRV
100   FORMAT(/' The symbol ',A1,'for lattice type is uncorrect.'/
     1 ' Symbol P has been assumed'/)
2     READ(IN,*)N,D3,DM,NH1,NTN,LSP,LSL,NPR,NST,KL,KY,KC,KO,KB,KA,KT,
     1 KD,KE,KOR,NI
      IF(KY.EQ.0)GO TO 5
      READ(IN,*)NNS,IZ,AL
      DO 4 I=1,20
      LA(I)='  '
4     ANAA(I)=0.0
      READ(IN,*)(LA(K),ANAA(K),K=1,NNS)
      DO 3 I=1,NNS
      MINUS(1)=LA1(1,I)
      MINUS(2)=LA1(2,I)
      NCS=2
      CALL MINUMA(NCS,MINUS)
      LA1(1,I)=MINUS(1)
3     LA1(2,I)=MINUS(2)
5     READ(IN,*)C,SC,A,SA
      WRITE(IO,'(''CELL '',F7.5,6F8.3)')AL,C,A
C-----Read atom symbols,coordinates,thermal parameters & e.s.d.'s
      IF(KL.EQ.4) GO TO 17
      READ(IN,'(A80)') FRT
      IF(KOR.EQ.0) GO TO 6
      GO TO (7,9,11),KL
6     GO TO (13,13,15,17),KL
7     DO 8 J=1,N
8     READ(IN,FRT)(SDOL(L,J),L=1,6),(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 20
9     DO 10 J=1,N
10    READ(IN,FRT)(SDOL(L,J),L=1,6),(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 20
11    DO 12 J=1,N
12    READ(IN,FRT)(SDOL(L,J),L=1,6),(V(I,J),S(I,J),I=1,3),
     1 (B(I,J),SB(I,J),I=1,6)
      GO TO 20
13    DO 14 J=1,N
14    READ(IN,FRT)(SDOL(L,J),L=1,6),(V(I,J),I=1,3),(S(I,J),I=1,3)
      GO TO 20
15    DO 16 J=1,N
16    READ(IN,FRT)(SDOL(L,J),L=1,6),(V(I,J),S(I,J),I=1,3)
      GO TO 20
17    DO 19 J=1,N
      READ(IN,101)(SDOL(L,J),L=1,6),(V(I,J),I=1,3),
     1 ((UNIM(I,K),K=1,5),I=1,3)
101   FORMAT(7X,6A1,2X,3F8.5,12X,3(5A1,3X))
      DO 19 I=1,3
      DO 18 JJ=1,5
18    II(JJ)=UNIM(I,JJ)
      CALL CONVE(II,DH)
19    S(I,J)=DH
20    DO 22 J=1,N
      MINUS(1)=SDOL(1,J)
      MINUS(2)=SDOL(2,J)
      NCS=2
      CALL MINUMA(NCS,MINUS)
      SDOL(1,J)=MINUS(1)
      SDOL(2,J)=MINUS(2)
      DO 21 L=1,6
21    AAAA(L)=SDOL(L,J)
      CALL LABL(AAAA,KY,NNS,LA1,LBA,KKD)
      SDL1(1,J)=LBA(1)
      SDL1(2,J)=LBA(2)
22    CONTINUE
      IF(KY.EQ.0)CALL ATOMLABL
C-----Calculated hydrogens
      IF(NH1.NE.0)THEN
      DO 23 I=1,NH1
23    READ(IN,'(80A1)')TIT
      ENDIF
C-----Torsion angles formed by non-bonded atoms
      IF(NTN.NE.0)THEN
      DO 24 I=1,NTN
24    READ(IN,'(80A1)')TIT
      ENDIF
C-----Planes
      IF(LSP.NE.0)THEN
      DO 25 I=1,LSP
25    READ(IN,'(80A1)')TIT
      ENDIF
C-----Lines
      IF(LSL.NE.0)THEN
      DO 26 I=1,LSL
26    READ(IN,'(80A1)')TIT
      ENDIF
C-----Ring puckering
      IF(NPR.NE.0)THEN
      DO 27 I=1,NPR
27    READ(IN,'(80A1)')TIT
      ENDIF
C-----Atomic environments
      IF(NST.NE.0)THEN
      DO 28 I=1,NST
28    READ(IN,'(80A1)')TIT
      ENDIF
C-----Equivalent positions
      READ(IN,*)IC,NE,NT
      IF(BRV.EQ.'P')KBRV=1
      IF(BRV.EQ.'A'.OR.BRV.EQ.'B'.OR.BRV.EQ.'C'.OR.BRV.EQ.'I')KBRV=2
      IF(BRV.EQ.'R')KBRV=3
      IF(BRV.EQ.'F')KBRV=4
      IF(KY.EQ.0.AND.IC.EQ.1)IZ=(NE+1)*KBRV
      IF(KY.EQ.0.AND.IC.EQ.-1)IZ=(NE+1)*2*KBRV
      WRITE(IO,'(''ZERR '',I3,6F7.3)')IZ,SC,SA
      IF(IC.EQ.1)KK=-KK
      WRITE(IO,'(''LATT '',I3)')KK
      DO 29 I=1,NE
      READ(IN,'(20A1)')STR
29    WRITE(IO,'(''SYMM '',20A1)')STR
C-----SFAC, UNIT and commands
      DO 30 I=1,20
      IF(KY.EQ.0)INA(I)=INA(I)*IZ
      IF(KY.EQ.1)INA(I)=ANAA(I)*IZ
30    CONTINUE
      WRITE(IO,'(''SFAC '',20(1X,A2))')(LA(I),I=1,NNS)
      WRITE(IO,'(''UNIT '',20(1X,I3))')(INA(I),I=1,NNS)
      WRITE(IO,'(''L.S.  5'')')
      WRITE(IO,'(''FMAP  2'')')
      WRITE(IO,'(''PLAN  -10'')')
      WRITE(IO,'(''WGHT  0.1000'')')
      WRITE(IO,'(''FVAR  1.0000'')')
C-----Atom coordinates
      DO 33 I=1,N
      KS=SDL2(I)
      DO 31 J=1,NNS
      IF(KS.EQ.LA(J))THEN
      NN=J
      GO TO 32
      ENDIF
31    CONTINUE
32    IF(ABS(B(1,I)).LT.1E-6.AND.KS.NE.'H ') B(1,I)=0.05
      IF(ABS(B(1,I)).LT.1E-6.AND.KS.EQ.'H ') B(1,I)=0.08
      IF(ABS(B(2,I)).LT.1E-6)THEN
      WRITE(IO,'(6A1,I3,3F10.5,''  11.00000'',F10.5)')
     1 (SDOL(L,I),L=1,6),NN,(V(K,I),K=1,3),B(1,I)
      ELSE
      WRITE(IO,'(6A1,I3,3F10.5,''  11.00000'',2F10.5,'' =''/5X,4F10.5)
     1 ')(SDOL(L,I),L=1,6),NN,(V(K,I),K=1,3),(B(K,I),K=1,6)
      ENDIF
33    CONTINUE
C-----HKLF and END
      WRITE(IO,'(''HKLF  4'')')
      WRITE(IO,'(''END'')')
      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 3 I=1,5
      IX(I)=0
      DO 1 K=1,10
      IF(IA(K).EQ.II(I)) GO TO 2
1     CONTINUE
2     IX(I)=K-1
3     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 MINUMA(N,STR)
C-----This routine transforms the lower case characters into upper
C-----case characters, in a string of N characters
      CHARACTER*1 MINU(26),MAIU(26),STR(N)
      COMMON/MIMA/MINU,MAIU
      DO 2 I=1,N
      DO 1 J=1,26
      IF(STR(I).NE.MINU(J)) GO TO 1
      STR(I)=MAIU(J)
      GO TO 2
1     CONTINUE
2     CONTINUE
      RETURN
      END
 
      SUBROUTINE LABL(AAAA,KY,NS,LA1,LBA,KKD)
C-----This routine finds the atom species from its label
      CHARACTER*1 AAAA(6),LA1(2,20),LBA(2),MINU(26),MAIU(26)
      COMMON/INPOU/IN,IO
     1      /MIMA/MINU,MAIU
      IF(KY.EQ.1)THEN
      DO 1 J=1,NS
      IF(AAAA(1).EQ.LA1(1,J).AND.AAAA(2).EQ.LA1(2,J))GO TO 3
1     CONTINUE
      DO 2 K=1,NS
      IF(AAAA(1).EQ.LA1(1,K))GO TO 4
2     CONTINUE
      WRITE(IO,100)AAAA
100   FORMAT('Atom ',6A1,' is not among the given species'/
     1 'The first two characters are assumed')
      LBA(1)=AAAA(1)
      LBA(2)=AAAA(2)
      KKD=1
      RETURN
3     LBA(1)=LA1(1,J)
      LBA(2)=LA1(2,J)
      RETURN
4     LBA(1)=LA1(1,K)
      LBA(2)=' '
      RETURN
      ENDIF
      LBA(1)=AAAA(1)
      DO 5 I=1,26
      IF(AAAA(2).EQ.MAIU(I))GO TO 6
5     CONTINUE
      LBA(2)=' '
      RETURN
6     LBA(2)=AAAA(2)
      RETURN
      END
 
      SUBROUTINE ATOMLABL
C-----Deduces the species of atoms and their number from the atom list
      CHARACTER*2 SDL2(500),LA(20),LARIS
      DIMENSION NS(500),INA(20)
      COMMON/GRG1/SDL2
     1      /GRG2/LA
     2      /GRG3/N,INA,NNS
     3      /INPOU/IN,IO
      DO 1 I=1,500
1     NS(I)=0
      NNS=0
      DO 2 I=1,20
      LA(I)='  '
2     INA(I)=0
      N1=0
      DO 4 I=1,N-1
      IF(NS(I).EQ.1)GO TO 4
      N1=N1+1
      LA(N1)=SDL2(I)
      NNS=NNS+1
      INA(N1)=1
      DO 3 J=I+1,N
      IF(SDL2(I).EQ.SDL2(J))THEN
      INA(N1)=INA(N1)+1
      NS(J)=1
      ENDIF
3     CONTINUE
4     CONTINUE
      DO 5 I=1,NNS
      IF(LA(I).EQ.'C ')THEN
      LARIS=LA(1)
      LA(1)=LA(I)
      LA(I)=LARIS
      NRIS=INA(1)
      INA(1)=INA(I)
      INA(I)=NRIS
      ELSEIF(LA(I).EQ.'H ')THEN
      LARIS=LA(2)
      LA(2)=LA(I)
      LA(I)=LARIS
      NRIS=INA(2)
      INA(2)=INA(I)
      INA(I)=NRIS
      ENDIF
5     CONTINUE
      DO 6 I=3,NNS-1
      DO 6 J=I+1,NNS
      IF(LA(I).GT.LA(J))THEN
      LARIS=LA(J)
      LA(J)=LA(I)
      LA(I)=LARIS
      NRIS=INA(J)
      INA(J)=INA(I)
      INA(I)=NRIS
      ENDIF
6     CONTINUE
      RETURN
      END
 
      BLOCK DATA
      CHARACTER*1 MINU(26),MAIU(26)
      COMMON/MIMA/MINU,MAIU
      DATA MINU/'a','b','c','d','e','f','g','h','i','j','k','l','m',
     1 'n','o','p','q','r','s','t','u','v','w','x','y','z'/
      DATA MAIU/'A','B','C','D','E','F','G','H','I','J','K','L','M',
     1 'N','O','P','Q','R','S','T','U','V','W','X','Y','Z'/
      END
