      PROGRAM PREP96
C**********************************************************************
C* Release September 1996                                             *
C*                      Program PREP96                                *
C*                                                                    *
C*                       by M. Nardelli                               *
C*  Dipartimento di Chimica Generale ed Inorganica, Chimica Analitica,*
C*             Chimica Fisica della Universita' di Parma              *
C*  Centro di Studio per la Strutturistica Diffrattometrica del CNR.  *
C*            Viale delle Scienze 78, I-43100 Parma, Italy            *
C*                                                                    *
C*                ----------------------------                        *
C*                                                                    *
C* This program sets up the input files for PARST and for THMV7 from  *
C* the name.lst file obtained by SHELXL-93.                           *
C* The computer asks for the names of the input and output files that *
C* must be keyed in by the user.                                      *
C*                                                                    *
C* N.B. The output files require a minimum of editing before to be    *
C*      used. In particular instructions for L.S. planes or lines,    *
C*      rings, comparison of molecules or moieties must be added.     *
C*                                                                    *
C*                      SUBROUTINES                                   *
C*                                                                    *
C* MINUMA                                                             *
C* ELB                                                                *
C* INTBL                                                              *
C* DCPNT                                                              *
C* SYMMCOD                                                            *
C* BLOCK DATA                                                         *
C**********************************************************************
      CHARACTER*1 TIT(120),ATM(6),AT(2,94),AT2,NU(10),BRV,SAT(2,20),
     1 ATMP(6,200),ATMH(6,200),SYM(100,48),LBA(2),TIT1(120)
      CHARACTER*14 FILIN,FILPAR,FILTHM
      DIMENSION X(3),U(6),SX(3),SU(6),C(3),A(3),SC(3),SA(3),ASPE(20),
     1 XP(3,200),XH(3,200),SXP(3,200),SXH(3,200),UP(6,200),UH(6,200),
     2 SUP(6,200),SUH(6,200)
      COMMON/GRP1/AT,NU
     1      /GRP2/PA(94)
     2      /GRP3/TIT
C-----Assign input and output files
      WRITE(*,100)
100   FORMAT(' Key in the name of the input file'/' ?>')
      READ(*,'(A14)')FILIN
      OPEN(UNIT=13,FILE=FILIN,FORM='FORMATTED')
      REWIND(UNIT=13)
      WRITE(*,101)
101   FORMAT(' Key in the name of output file for PARST'/' ?>')
      READ(*,'(A14)')FILPAR
      OPEN(UNIT=15,FILE=FILPAR,FORM='FORMATTED')
      REWIND(UNIT=15)
      WRITE(*,102)
102   FORMAT(' Key in the name of output file for THMV'/' ?>')
      READ(*,'(A14)')FILTHM
      OPEN(UNIT=16,FILE=FILTHM,FORM='FORMATTED')
      REWIND(UNIT=16)
      OPEN(UNIT=17,STATUS='SCRATCH',FORM='FORMATTED')
      REWIND(UNIT=17)
      OPEN(UNIT=18,STATUS='SCRATCH',FORM='FORMATTED')
      REWIND(UNIT=18)
C-----Assign zeros to counters and codes
      N=0
      NT=0
      NP=0
      NH=0
      KDC=0
      KKDC=0
      KKD=0
      DO 1 I=1,2
      DO 1 J=1,20
      ASPE(J)=0.0
1     SAT(I,J)=' '
C-----Read data
      DO 12 I=1,50
      READ(13,'(120A1)')TIT
      CALL ELB(NBS)
C-----Read and write title
      IF(TIT(1).EQ.'+'.OR.(TIT(1).EQ.' '.AND.TIT(2).EQ.' '.AND.
     1 TIT(3).EQ.' '.AND.TIT(4).EQ.' '))GO TO 12
      NC=120
      CALL MINUMA(TIT,NC)
      IF(TIT(1).EQ.'T'.AND.TIT(2).EQ.'I'.AND.TIT(3).EQ.'T'.AND.TIT(4)
     1 .EQ.'L') THEN
      WRITE(15,'(70A1)')(TIT(L),L=7,76)
      WRITE(16,'(70A1)')(TIT(L),L=7,76)
C-----Read wavelength and cell parameters
      ELSEIF(TIT(1).EQ.'C'.AND.TIT(2).EQ.'E'.AND.TIT(3).EQ.'L'.AND.
     1 TIT(4).EQ.'L') THEN
      CALL INTBL
      WRITE(18,'(115A1)')(TIT(L),L=6,120)
      BACKSPACE 18
      READ(18,*)ALA,C,A
C-----Read Z and e.s.d.'s of cell parameters
      ELSEIF(TIT(1).EQ.'Z'.AND.TIT(2).EQ.'E'.AND.TIT(3).EQ.'R'.AND.
     1 TIT(4).EQ.'R') THEN
      CALL INTBL
      WRITE(18,'(115A1)')(TIT(L),L=6,120)
      NB=0
      DO 2 L=6,120
      IF(TIT(L).NE.' ') GO TO 2
      IF(TIT(L+1).EQ.' '.AND.TIT(L+2).EQ.' ') GO TO 3
      NB=NB+1
2     CONTINUE
3     BACKSPACE 18
      DO 4 K=1,3
4     SA(K)=0.0
      IF(NB.GT.3) THEN
      READ(18,*)IZ,SC,SA
      ELSE
      READ(18,*)IZ,SC
      ENDIF
C-----Read Bravais lattice
      ELSEIF(TIT(1).EQ.'L'.AND.TIT(2).EQ.'A'.AND.TIT(3).EQ.'T'.AND.
     1 TIT(4).EQ.'T') THEN
      WRITE(18,'(115A1)')(TIT(L),L=6,120)
      BACKSPACE 18
      READ(18,*)LATT
      IF(ABS(LATT).EQ.1)BRV='P'
      IF(ABS(LATT).EQ.2)BRV='I'
      IF(ABS(LATT).EQ.3)BRV='R'
      IF(ABS(LATT).EQ.4)BRV='F'
      IF(ABS(LATT).EQ.5)BRV='A'
      IF(ABS(LATT).EQ.6)BRV='B'
      IF(ABS(LATT).EQ.7)BRV='C'
      WRITE(15,'(A1)')BRV
      KKDC=1
C-----Read equivalent positions
      ELSEIF(TIT(1).EQ.'S'.AND.TIT(2).EQ.'Y'.AND.TIT(3).EQ.'M'.AND.
     1 TIT(4).EQ.'M') THEN
      CALL ELB(NBS)
      CALL INTBL
      CALL DCPNT
      CALL SYMMCOD
      KKD=KKD+1
      DO 5 L=1,100
5     SYM(L,KKD)=TIT(L)
      ELSEIF(TIT(1).EQ.'S'.AND.TIT(2).EQ.'F'.AND.TIT(3).EQ.'A'.AND.
     1 TIT(4).EQ.'C') THEN
      CALL INTBL
      NAT=0
      KDC=0
      DO 7 L=6,120
      IF(KDC.EQ.0)GO TO 6
      KDC=0
      GO TO 7
6     IF(TIT(L).EQ.' '.OR.KDC.EQ.1) GO TO 7
      NAT=NAT+1
      SAT(1,NAT)=TIT(L)
      SAT(2,NAT)=TIT(L+1)
      KDC=1
7     CONTINUE
C-----Read numbers of atoms of each species
      ELSEIF(TIT(1).EQ.'U'.AND.TIT(2).EQ.'N'.AND.TIT(3).EQ.'I'.AND.
     1 TIT(4).EQ.'T') THEN
      CALL INTBL
      KK=121
8     CONTINUE
      KK=KK-1
      IF(TIT(KK).EQ.' ')GO TO 8
      LL=6
      IDEP=1
37    CONTINUE
      IF(TIT(LL).EQ.' ')IDEP=IDEP+1
      LL=LL+1
      IF(LL.LT.KK)GO TO 37
      WRITE(18,'(115A1)')(TIT(L),L=6,KK)
      BACKSPACE 18
      READ(18,*,END=9)(ASPE(L),L=1,IDEP)
9     NAT=0
      RR=1E-4
      DO 10 J=1,20
      IF(ASPE(J).LT.RR)GO TO 11
      NAT=NAT+1
10    ASPE(NAT)=ASPE(J)/IZ
11    CONTINUE
      ENDIF
12    CONTINUE
C-----Choice of SHELXL
      WRITE(*,'('' Key in 0 if SHELXL-93 or 1 if SHELXL-96''/
     1 '' ?>'')')
      READ(*,*)KSH
C-----Read coordinate and thermal parameter table
      IA=1
13    READ(13,'(120A1)')TIT
      CALL ELB(NBS)
      NC=36
      CALL MINUMA(TIT,NC)
      IF(TIT(1).NE.'A')GO TO 13
      IF(TIT(2).NE.'T')GO TO 13
      IF(TIT(3).NE.'O')GO TO 13
      IF(TIT(4).NE.'M')GO TO 13
      IF(TIT(16).NE.'X')GO TO 13
      IF(TIT(26).NE.'Y')GO TO 13
      IF(TIT(36).NE.'Z')GO TO 13
14    READ(13,'(120A1)')TIT
      READ(13,'(120A1)')TIT
      CALL ELB(NBS)
      IF(TIT(1).EQ.' '.AND.TIT(2).EQ.' '.AND.TIT(3).EQ.' '.AND.
     1 TIT(4).EQ.' ')GO TO 27
      REWIND (UNIT=18)
      WRITE(18,'(120A1)')TIT
      BACKSPACE 18
      N=N+1
      READ(18,103)ATM,X,PE,U
103   FORMAT(6A1,3X,3(2X,F8.5),5X,F7.5,2X,6(2X,F8.5))
      IF(ABS(X(1)).GT.0.5.OR.ABS(X(2)).GT.0.5.OR.ABS(X(3)).GT.0.5)IA=2
      READ(13,'(120A1)')TIT
      CALL ELB(NBS)
      REWIND (UNIT=18)
      WRITE(18,'(120A1)')TIT
      BACKSPACE 18
C-----Read the second row according to SHELXL-93 or SHELXL-96
      IF(KSH.EQ.0)THEN
      READ(18,'(F7.5,2(3X,F7.5),14X,6(3X,F7.5))')SX,SU
      ELSEIF(NBS.LT.5)THEN
      READ(18,'(7X,3(3X,F7.5),14X,6(3X,F7.5))')SX,SU
      ELSE
      READ(18,'(F7.5,2(3X,F7.5),14X,6(3X,F7.5))')SX,SU
      SU(1)=SX(2)
      DO 36 L=1,3
36    SX(L)=0.0
      ENDIF
C-----Check for the atom kinds
      NC=6
      CALL MINUMA(ATM,NC)
      DO 15 J=1,NAT
      IF(ATM(1).EQ.SAT(1,J).AND.ATM(2).EQ.SAT(2,J))GO TO 17
15    CONTINUE
      DO 16 K=1,NAT
      IF(ATM(1).EQ.SAT(1,K))GO TO 18
16    CONTINUE
      WRITE(*,110)ATM
110   FORMAT(' Atom ',6A1,' is not among the given species'/
     1 ' The first two characters are assumed')
      LBA(1)=ATM(1)
      LBA(2)=ATM(2)
      GO TO 19
17    LBA(1)=SAT(1,J)
      LBA(2)=SAT(2,J)
      GO TO 19
18    LBA(1)=SAT(1,K)
      LBA(2)=' '
19    DO 20 I=1,94
      IF(LBA(1).EQ.AT(1,I).AND.LBA(2).EQ.AT(2,I))GO TO 38
20    CONTINUE
      WRITE(*,'('' Atom '',2A1,'' does not exist'')')LBA
38    AW=PA(I)
C-----Separate H atoms
      IF(LBA(1).EQ.'H'.AND.LBA(2).EQ.' ')THEN
      NH=NH+1
      DO 21 L=1,6
21    ATMH(L,NH)=ATM(L)
      DO 22 K=1,3
      XH(K,NH)=X(K)
22    SXH(K,NH)=SX(K)
      DO 23 K=1,6
      UH(K,NH)=U(K)
23    SUH(K,NH)=SU(K)
      ELSE
C-----Separate non-H atoms
      NP=NP+1
      DO 24 L=1,6
24    ATMP(L,NP)=ATM(L)
      DO 25 K=1,3
      XP(K,NP)=X(K)
25    SXP(K,NP)=SX(K)
      DO 26 K=1,6
      UP(K,NP)=U(K)
26    SUP(K,NP)=SU(K)
      ENDIF
C-----Set up file for THMV
      IF(U(2).LT.1E-5.AND.U(3).LT.1E-5) GO TO 14
      NT=NT+1
      RIS=U(4)
      U(4)=U(6)
      U(6)=RIS
      RIS=SU(4)
      SU(4)=SU(6)
      SU(6)=RIS
      WRITE(17,104)ATM,X,AW,PE,U,SU,ATM
104   FORMAT(6A1,21X,3F9.6,2F5.1/6F9.6/6F10.5,6A1)
      GO TO 14
C-----Write the file for PARST
27    IF(KKDC.EQ.0)WRITE(15,'(''P'')')
      WRITE(15,'(I3,'',2.5,4.0,0,0,0,0,0,0,1,1,1,0,1,1,1,1,1,2,0'')')N
      WRITE(15,'(I2,I3,F8.5)')NAT,IZ,ALA
      CALL STRAT(NAT,SAT,ASPE,TIT1)
      WRITE(15,'(120A1)')TIT1
      WRITE(15,'(3(F8.4,1X),3(F5.4,1X),3(F6.2,1X),3(F3.2,1X))')C,SC,A,SA
      WRITE(15,106)
106   FORMAT('(6A1,6F9.5/6F9.5/6F9.5)')
      DO 28 I=1,NP
28    WRITE(15,107)(ATMP(L,I),L=1,6),(XP(K,I),K=1,3),(SXP(K,I),K=1,3),
     1 (UP(J,I),J=1,6),(SUP(J,I),J=1,6)
107   FORMAT(6A1,6F9.5/6F9.5/6F9.5)
      DO 29 I=1,NH
29    WRITE(15,107)(ATMH(L,I),L=1,6),(XH(K,I),K=1,3),(SXH(K,I),K=1,3),
     1 (UH(J,I),J=1,6),(SUH(J,I),J=1,6)
      IC=-1
      IF(LATT.LT.0)IC=1
      WRITE(15,'(3I4)')IC,KKD,IA
      IF(KKD.EQ.0) GO TO 31
      DO 30 L=1,KKD
      WRITE(15,'(100A1)')(SYM(K,L),K=1,100)
30    CONTINUE
C-----Write the file for TMV
31    WRITE(16,108)C,A
108   FORMAT(F6.3,3X,F7.3,4X,F7.3,3X,F6.2,2(4X,F6.2),7X,'0',3X,'0')
      MNT=-NT
      WRITE(16,109)MNT,NT
109   FORMAT(I5,2(4X,'1'),4X,'8',3(4X,'0'),I5,9X,'1',7X,'-1')
      REWIND 17
      N3=3*NT
      DO 32 I=1,N3-3
      READ(17,'(120A1)',END=33)TIT
      WRITE(16,'(120A1)')TIT
      READ(17,'(120A1)',END=33)TIT
      WRITE(16,'(120A1)')TIT
32    READ(17,'(120A1)',END=33)TIT
33    REWIND 17
      DO 34 I=1,N3-3
      READ(17,'(120A1)',END=35)TIT
      READ(17,'(120A1)',END=35)TIT
      READ(17,'(120A1)',END=35)TIT
34    WRITE(16,'(120A1)')TIT
35    CLOSE(UNIT=13)
      CLOSE(UNIT=15)
      CLOSE(UNIT=16)
      CLOSE(UNIT=17)
      CLOSE(UNIT=18)
      STOP
      END
 
      SUBROUTINE MINUMA(STR,N)
C-----This routine transforms the lower case characters into upper
C-----case characters, in a string of N characters (max.120)
      CHARACTER*1 MINU(26),MAIU(26),STR(N)
      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'/
      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 ELB(NBS)
C-----Count and eliminate leading blanks in a string
      CHARACTER*1 TIT(120)
      COMMON/GRP3/TIT
      N1=120
      NBS=0
      DO 1 I=1,N1
      IF(TIT(I).NE.' ')GO TO 2
1     NBS=NBS+1
2     DO 4 K=1,N1
      IF(TIT(1).EQ.' ')THEN
      DO 3 J=1,N1-1
3     TIT(J)=TIT(J+1)
      N1=N1-1
      ENDIF
4     CONTINUE
      RETURN
      END
 
      SUBROUTINE INTBL
C-----Eliminate redundant intermediate blanks
      CHARACTER*1 TIT(120)
      COMMON/GRP3/TIT
      DO 2 K=1,5
      N1=120
      DO 2 I=1,N1-1
      IF(TIT(I).EQ.' '.AND.TIT(I+1).EQ.' ')THEN
      DO 1 J=I,N1-1
1     TIT(J)=TIT(J+1)
      N1=N1-1
      ENDIF
2     CONTINUE
      RETURN
      END
 
      SUBROUTINE DCPNT
C-----Put missing zeros before decimal points in an alphanumeric
C-----string
      CHARACTER*1 TIT(120),AT(2,94),AT2,NU(10)
      COMMON/GRP1/AT,NU
      COMMON/GRP3/TIT
      N=120
      DO 5 I=1,3
      IF(I.EQ.1)K=1
      IF(I.GT.1)K=N1+2
      DO 2 J=K,N
      IF(TIT(J).NE.'.')GO TO 2
      N1=J
      DO 1 L=1,10
      IF(J.GT.1.AND.TIT(J-1).EQ.NU(L))GO TO 5
1     CONTINUE
      GO TO 3
2     CONTINUE
      GO TO 5
3     DO 4 J=1,(N-N1)
4     TIT(N-J+1)=TIT(N-J)
      TIT(N1)='0'
5     CONTINUE
      RETURN
      END
 
      SUBROUTINE SYMMCOD
C-----Changes a SYMM string of SHELXL92 for PARST
      CHARACTER*1 TIT(120),STR(3,40)
      DIMENSION NS(3)
      COMMON/INPOU/IN,IO
     1      /GRP3/TIT
      DO 1 I=1,3
      NS(I)=0
      DO 1 J=1,40
1     STR(I,J)=' '
C-----Eliminate zeros
      DO 2 I=1,120
2     IF(TIT(I).EQ.'0')TIT(I)=' '
C-----Separate three strings
      N1=6
      DO 5 I=1,2
      DO 3 J=N1,120
      IF(TIT(J).EQ.',')GO TO 4
      NS(I)=NS(I)+1
      IF(NS(I).GT.40)GO TO 5
3     STR(I,NS(I))=TIT(J)
4     N1=N1+NS(I)+1
5     CONTINUE
      N1=6+NS(1)+NS(2)+2
      DO 6 L=N1,N1+39
      NS(3)=NS(3)+1
6     STR(3,NS(3))=TIT(L)
      N2=0
      DO 7 K=1,40
      IF(STR(3,41-K).NE.' ')GO TO 8
      N2=N2+1
7     CONTINUE
8     NS(3)=NS(3)-N2
C-----Transform decimal numbers in ratios expressed as characters
      DO 18 I=1,3
      DO 9 K=1,40
      IF(STR(I,K).EQ.'.')GO TO 10
9     CONTINUE
      GO TO 18
10    DO 17 J=1,NS(I)
      IF(STR(I,J).NE.'.')GO TO 17
C-----0.50 transformed to 1/2
      IF(STR(I,J+1).EQ.'5')THEN
      IF(STR(I,J+2).EQ.' ')GO TO 12
      IF(NS(I).EQ.40)NS(I)=39
      DO 11 K=1,J
11    STR(I,(NS(I)-K+2))=STR(I,(NS(I)-K+1))
12    STR(I,J)='1'
      STR(I,J+1)='/'
      STR(I,J+2)='2'
C-----0.25 transformed to 1/4
      ELSEIF(STR(I,J+1).EQ.'2'.AND.STR(I,J+2).EQ.'5')THEN
      STR(I,J)='1'
      STR(I,J+1)='/'
      STR(I,J+2)='4'
      ELSEIF(STR(I,J+1).EQ.'7'.AND.STR(I,J+2).EQ.'5')THEN
      STR(I,J)='3'
      STR(I,J+1)='/'
      STR(I,J+2)='4'
C-----0.33 transformed to 1/3
      ELSEIF(STR(I,J+1).EQ.'3'.AND.STR(I,J+2).EQ.'3')THEN
      STR(I,J)='1'
      STR(I,J+1)='/'
      STR(I,J+2)='3'
      DO 13 K=J+3,40
13    IF(STR(I,K).EQ.'3')STR(I,K)=' '
C-----0.66 transformed to 2/3
      ELSEIF(STR(I,J+1).EQ.'6'.AND.(STR(I,J+2).EQ.'6'.OR.STR(I,J+2)
     1 .EQ.'7'))THEN
      STR(I,J)='2'
      STR(I,J+1)='/'
      STR(I,J+2)='3'
      DO 14 K=J+3,40
14    IF(STR(I,K).EQ.'6'.OR.STR(I,K).EQ.'7')STR(I,K)=' '
C-----0.16 transformed to 1/6
      ELSEIF(STR(I,J+1).EQ.'1'.AND.STR(I,J+2).EQ.'6')THEN
      STR(I,J)='1'
      STR(I,J+1)='/'
      STR(I,J+2)='6'
      DO 15 K=J+3,40
15    IF(STR(I,K).EQ.'6'.OR.STR(I,K).EQ.'7')STR(I,K)=' '
C-----0.83 transformed to 5/6
      ELSEIF(STR(I,J+1).EQ.'8'.AND.STR(I,J+2).EQ.'3')THEN
      STR(I,J)='5'
      STR(I,J+1)='/'
      STR(I,J+2)='6'
      DO 16 K=J+3,40
16    IF(STR(I,K).EQ.'3')STR(I,K)=' '
      ENDIF
17    CONTINUE
18    CONTINUE
C-----Join strings
      DO 21 I=1,3
      DO 20 L=1,10
      DO 20 J=1,39
      IF(STR(I,J).NE.' ')GO TO 20
      DO 19 K=J,39
19    STR(I,K)=STR(I,K+1)
20    CONTINUE
21    CONTINUE
      DO 22 I=1,120
22    TIT(I)=' '
      DO 23 I=1,39
23    TIT(I)=STR(1,I)
      TIT(40)=','
      DO 24 I=1,39
24    TIT(I+40)=STR(2,I)
      TIT(80)=','
      DO 25 I=1,39
25    TIT(I+80)=STR(3,I)
C-----Eliminate blanks
      DO 28 K=1,20
      DO 27 I=1,119
      IF(TIT(I).NE.' ')GO TO 27
      DO 26 J=I,119
26    TIT(J)=TIT(J+1)
27    CONTINUE
28    CONTINUE
      RETURN
      END
 
      BLOCK DATA
      CHARACTER*1 AT(2,94),NU(10)
      COMMON/GRP1/AT,NU
     1      /GRP2/PA(94)
      DATA AT/'H',' ','H','E','L','I','B','E','B',' ',
     9'C',' ','N',' ','O',' ','F',' ','N','E',
     1'N','A','M','G','A','L','S','I','P',' ',
     1'S',' ','C','L','A','R','K',' ','C','A','S','C',
     2'T','I','V',' ','C','R','M','N','F','E',
     2'C','O','N','I','C','U','Z','N','G','A','G','E',
     3'A','S','S','E','B','R','K','R','R','B',
     3'S','R','Y',' ','Z','R','N','B','M','O','T','C',
     4'R','U','R','H','P','D','A','G','C','D',
     4'I','N','S','N','S','B','T','E','I',' ','X','E',
     5'C','S','B','A','L','A','C','E','P','R',
     5'N','D','P','M','S','M','E','U','G','D','T','B',
     6'D','Y','H','O','E','R','T','M','Y','B',
     6'L','U','H','F','T','A','W',' ','R','E','O','S',
     7'I','R','P','T','A','U','H','G','T','L',
     7'P','B','B','I','P','O','A','T','R','N','F','R',
     8'R','A','A','C','T','H','P','A','U',' ','N','P','P','U'/
      DATA PA/1.0079,4.0026,6.941,9.01218,10.81,12.011,14.0067,
     A15.9994,18.9984,20.179,22.98977,24.305,26.98154,28.086,
     B30.97376,32.06,35.453,39.948,39.098,40.08,44.9559,47.9,
     C50.9415,51.996,54.938,55.847,58.9332,58.71,63.546,65.38,
     D69.72,72.59,74.9216,78.96,79.904,83.8,85.4678,87.62,
     E88.9059,91.22,92.9064,95.94,98.9062,101.07,102.9055,
     F106.4,107.868,112.4,114.82,118.69,121.75,127.6,126.9045,
     G131.3,132.9044,137.34,138.9055,140.12,140.9077,144.24,
     H147.,150.4,151.96,157.25,158.9254,162.5,164.9304,167.26,
     I168.9342,173.04,174.97,178.49,180.9479,183.85,186.2,190.2,
     L192.22,195.09,196.9665,200.59,204.37,207.2,208.9804,210.,
     M210.,222.,223.,226.0254,227.,232.0381,231.0359,238.029,
     N237.0482,242./
      DATA NU/'0','1','2','3','4','5','6','7','8','9'/
      END
 
      SUBROUTINE STRAT(NA,STRA,FST,TIT1)
C-----Encodes in a string the atom symbols and their numbers
      CHARACTER*1 STRA(2,20),TIT1(120)
      DIMENSION FST(20)
      WRITE(18,100)((STRA(L,I),L=1,2),FST(I),I=1,NA)
100   FORMAT(20('''',2A1,'''',',',F7.3,','))
      BACKSPACE 18
      READ(18,'(120A1)')TIT1
      DO 35 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 36 K=1,4
36    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
35    CONTINUE
      DO 37 K=1,10
      DO 37 I=2,119
      IF(TIT1(I).EQ.' '.AND.TIT1(I+1).NE.'''')THEN
      TIT1(119)=' '
      DO 38 J=I,119
38    TIT1(J)=TIT1(J+1)
      ENDIF
37    CONTINUE
      RETURN
      END
