      PROGRAM CIFPARST
C***********************************************************************
C* Release of May 1997                                                 *
C*                     Program CIFPARST                                *
C*                                                                     *
C*                      by M. Nardelli                                 *
C*                                                                     *
C* Dipartimento di Chimica Generale ed Inorganica, Chimica Analitica,  *
C*      Chimica Fisica della Universita' degli Studi di Parma,         *
C*   Centro di Studio per la Strutturistica Diffrattometrica del CNR   *
C*          Viale delle Scienze 78, I-43100 Parma, Italy               *
C*               E-mail: nardelli@iprunic.cce.unipr.it                 *
C*                                                                     *
C* This program creates the input file for PARST97 from CIF. The file  *
C* may require some editing to consider: l.s. planes, l.s. lines, ring *
C* conformation analysis, comparison of molecules or fragments, etc.   *
C*                                                                     *
C* Suggestions and warnings:                                           *
C* ========================                                            *
C* The program looks for the CIF items giving data necessary to PARST: *
C* _chemical_formula_sum_                                              *
C* _cell_length_a, _cell_length_b, _cell_length_c                      *
C* _cell_angle_alpha, _cell_angle_beta, _cell_angle_gamma (that must   *
C*   be present even if equal to 90 or 120 deg)                        *
C* _cell_formula_units_Z                                               *
C* _symmetry_space_group_name_H-M                                      *
C* _diffrn_radiation_wavelength                                        *
C* better when the datum is on the same line of the item-name which is *
C* referred to                                                         *
C* loop_                                                               *
C* _symmetry_equiv_pos_as_xyz  (no equiv. pos. on this line)           *
C* (equivalent positions)                                              *
C* loop_                                                               *
C* _atom_site_label                                                    *
C* _atom_site_fract_x                                                  *
C* _atom_site_fract_y                                                  *
C* _atom_site_fract_z                                                  *
C* (only one line for each atom)                                       *
C* loop_                                                               *
C* _atom_site_aniso_label                                              *
C* _atom_site_aniso_U11                                                *
C* _atom_site_aniso_U22                                                *
C* _atom_site_aniso_U33                                                *
C* _atom_site_aniso_U23                                                *
C* _atom_site_aniso_U13                                                *
C* _atom_site_aniso_U12                                                *
C* (only one line for each atom)                                       *
C* It is saving time to have them at the beginning of the file.        *
C* Redundant blanks and unnecessary comments are time consuming.       *
C* Spurious characters can have dangerous effects when running         *
C* the program.                                                        *
C*                       ----------------------                        *
C* "The Crystallographic Information File (CIF): a New Standard        *
C*  Archive File for Crystallography" [Acta Cryst.(1991). A47, 655-    *
C*  685]                                                               *
C***********************************************************************
      CHARACTER*1 TIT(80),STR1(20,60),STR(50),STRA(2,20),CHR1,CHR2,
     1 ZED(6),STG(25,192),STC(25,96),FORSU(21),CLA(13),CLAL(12),
     2 UNZ(21),HMSG(30),SYEP(26),WVL(28),LOP(5),ATSL(10),HMS(30),
     3 WL(10),TIT1(120),XTIT(20,80),UTIT(20,80),ANS(5),ATM(500,6),
     4 ATU(500,6),STRR(50),HAT(500,6),STRB(50),ATM1(20,2)
      DIMENSION FST(20),NC(20),C(3),SC(3),A(3),SA(3),LX(5),LU(7),
     1 XX(500,4),SX(500,4),U(500,6),SU(500,6)
      COMMON/INPOU/IN,IO
     1      /GRP1/NA,NT,NAU,IZ,Z,KZ
     2      /GRP2/STRA
     3      /GRP3/ATM,ATU
     4      /GRP4/XX,SX
     5      /GRP5/U,SU
     6      /GRP6/HMS,TIT1
     7      /GRP7/C,SC,A,SA,ALA
     8      /GRP8/IC,NE
     9      /GRP9/STG,STC
     1      /LBL2/NS
     2      /LBL3/ATM1
      DATA FORSU/'_','C','H','E','M','I','C','A','L','_','F','O','R',
     1 'M','U','L','A','_','S','U','M'/
      DATA CLA/'_','C','E','L','L','_','L','E','N','G','T','H','_'/
      DATA CLAL/'_','C','E','L','L','_','A','N','G','L','E','_'/
      DATA UNZ/'_','C','E','L','L','_','F','O','R','M','U','L','A','_',
     1 'U','N','I','T','S','_','Z'/
      DATA HMSG/'_','S','Y','M','M','E','T','R','Y','_','S','P','A',
     1 'C','E','_','G','R','O','U','P','_','N','A','M','E','_','H','-',
     2 'M'/
      DATA SYEP/'_','S','Y','M','M','E','T','R','Y','_','E','Q','U',
     1 'I','V','_','P','O','S','_','A','S','_','X','Y','Z'/
      DATA WVL/'_','D','I','F','F','R','N','_','R','A','D','I','A',
     1 'T','I','O','N','_','W','A','V','E','L','E','N','G','T','H'/
      DATA ATSL/'_','A','T','O','M','_','S','I','T','E'/
      DATA LOP/'L','O','O','P','_'/
      DATA ANS/'A','N','I','S','O'/
      IN=13
      IO=15
      CALL INPOUT
      OPEN(UNIT=10,STATUS='SCRATCH',FORM='FORMATTED')
      DO 1 I=1,3
      A(I)=90.0
1     SA(I)=0.0
      K1=0
      K2=0
      K3=0
      K4=0
      K5=0
      K6=0
      K7=0
      K8=0
      KD=0
      KA=0
      NX=0
      NU=0
      NT=0
      NAU=0
      KX=0
      KU=0
2     CALL READLINE(TIT,IER)
      IF(IER.EQ.1)GO TO 68
3     IF(K1.EQ.1) GO TO 8
C-----Formula_sum
      DO 4 I=1,21
      IF(TIT(I).NE.FORSU(I))GO TO 8
4     CONTINUE
      NB=21
      CALL ADDLINE(TIT,NB)
      N1=0
      DO 5 I=1,80
      IF(TIT(I).EQ.''''.OR.TIT(I).EQ.';'.OR.TIT(I).EQ.'"')THEN
      IF(N1.EQ.0)N1=I
      IF(N1.NE.0)N2=I
      ENDIF
5     CONTINUE
      NCR=N2-N1-1
      DO 6 I=1,NCR
6     STRB(I)=TIT(N1+I)
      WRITE(IO,'(''TITLE'',2X,50A1)')(STRB(I),I=1,NCR)
      K1=1
      GO TO 2
C-----Cell sides
8     IF(K2.EQ.1)GO TO 12
      DO 9 I=1,13
      IF(TIT(I).NE.CLA(I))GO TO 12
9     CONTINUE
      NB=13
      CALL ADDLINE(TIT,NB)
      N=0
      DO 10 I=16,50
      IF(TIT(I).EQ.' ')GO TO 11
      N=N+1
10    STR(I-15)=TIT(I)
11    CONTINUE
      CALL STRING1(N,STR,AA,DD)
      KD=KD+1
      IF(TIT(14).EQ.'A')THEN
      C(1)=AA
      SC(1)=DD
      ELSEIF(TIT(14).EQ.'B')THEN
      C(2)=AA
      SC(2)=DD
      ELSEIF(TIT(14).EQ.'C')THEN
      C(3)=AA
      SC(3)=DD
      ENDIF
      IF(KD.LT.3)GO TO 2
      K2=1
C-----Cell angles
12    IF(K3.EQ.1)GO TO 20
      DO 13 I=1,12
      IF(TIT(I).NE.CLAL(I))GO TO 20
13    CONTINUE
      NB=17
      CALL ADDLINE(TIT,NB)
      N=0
      IF(TIT(13).EQ.'A')THEN
      DO 14 I=19,50
      IF(TIT(I).EQ.' ')GO TO 15
      N=N+1
14    STR(I-18)=TIT(I)
15    CONTINUE
      ELSEIF(TIT(13).EQ.'B')THEN
      DO 16 I=18,50
      IF(TIT(I).EQ.' ')GO TO 17
      N=N+1
16    STR(I-17)=TIT(I)
17    CONTINUE
      ELSEIF(TIT(13).EQ.'G')THEN
      DO 18 I=19,50
      IF(TIT(I).EQ.' ')GO TO 19
      N=N+1
18    STR(I-18)=TIT(I)
19    CONTINUE
      ENDIF
      CALL STRING1(N,STR,AA,DD)
      KA=KA+1
      IF(TIT(13).EQ.'A')THEN
      A(1)=AA
      SA(1)=DD
      ELSEIF(TIT(13).EQ.'B')THEN
      A(2)=AA
      SA(2)=DD
      ELSEIF(TIT(13).EQ.'G')THEN
      A(3)=AA
      SA(3)=DD
      ENDIF
      IF(KA.LT.3)GO TO 2
      K3=1
C-----Number of molecules Z
20    IF(K4.EQ.1)GO TO 23
      DO 21 I=1,21
      IF(TIT(I).NE.UNZ(I))GO TO 23
21    CONTINUE
      NB=21
      CALL ADDLINE(TIT,NB)
C******************
      DO 22 I=23,28
22    ZED(I-22)=TIT(I)
      WRITE(10,*)ZED
      BACKSPACE 10
C     READ(10,*)IZ
      KZ=0
      READ(10,*)Z
      IZ=Z
      IF(ABS(Z-IZ).GT.0.1)KZ=1
C******************
      K4=1
      GO TO 2
C-----Hermann-Mauguin symbol
23    IF(K5.EQ.1)GO TO 28
      DO 24 I=1,30
      IF(TIT(I).NE.HMSG(I))GO TO 28
24    CONTINUE
      NB=30
      CALL ADDLINE(TIT,NB)
      DO 25 I=32,61
25    HMS(I-31)=TIT(I)
      DO 27 I=1,29
      IF(HMS(I).EQ.' '.OR.HMS(I).EQ.''''.OR.HMS(I).EQ.'"')THEN
      HMS(30)=' '
      DO 26 J=I,29
      HMS(J)=HMS(J+1)
26    CONTINUE
      ENDIF
27    CONTINUE
      K5=1
      GO TO 2
C-----Wavelength ALA
28    IF(K6.EQ.1)GO TO 31
      DO 29 I=1,28
      IF(TIT(I).NE.WVL(I))GO TO 31
29    CONTINUE
      NB=28
      CALL ADDLINE(TIT,NB)
      DO 30 I=30,39
30    WL(I-29)=TIT(I)
      WRITE(10,*)WL
      BACKSPACE 10
      READ(10,*)ALA
      K6=1
      GO TO 2
31    IF(K7.EQ.1)GO TO 67
C-----Looks for a LOOP_ string
      DO 32 I=1,5
      IF(TIT(I).NE.LOP(I))GO TO 2
32    CONTINUE
C-----Reads and checks the string following the LOOP_ one
33    CALL READLINE(TIT,IER)
      IF(TIT(18).EQ.'R'.AND.TIT(19).EQ.'A'.AND.TIT(20).EQ.'T'.AND.
     1 TIT(21).EQ.'I'.AND.TIT(22).EQ.'O')GO TO 33
      IF(IER.EQ.1)GO TO 68
      IF(TIT(1).NE.'_') GO TO 42
C-----Looks for the string _symmetry_equiv_pos_as_xyz
      DO 34 I=1,26
      IF(TIT(I).NE.SYEP(I)) GO TO 35
34    CONTINUE
      GO TO 65
C-----Looks for the strings containing the substring _ATOM_SITE_
35    DO 36 I=1,10
      IF(TIT(I).NE.ATSL(I))GO TO 3
36    CONTINUE
C-----Looks for the strings containing the substring ANISO
      DO 37 I=1,5
      IF(TIT(I+11).NE.ANS(I))GO TO 39
37    CONTINUE
      NU=NU+1
      DO 38 L=1,80
38    UTIT(NU,L)=TIT(L)
      GO TO 33
C-----Head strings of the coordinate loop
39    NX=NX+1
      DO 40 L=1,80
40    XTIT(NX,L)=TIT(L)
41    GO TO 33
C-----Atomic coordinates
42    BACKSPACE IN
      IF(KX.EQ.1)GO TO 53
      IF(NX.NE.0)THEN
      DO 43 I=1,NX
      IF(XTIT(I,12).EQ.'L'.AND.XTIT(I,13).EQ.'A'.AND.XTIT(I,14).EQ.'B'.
     1 AND.XTIT(I,15).EQ.'E'.AND.XTIT(I,16).EQ.'L')LX(1)=I
      IF(XTIT(I,12).EQ.'F'.AND.XTIT(I,18).EQ.'X')LX(2)=I
      IF(XTIT(I,12).EQ.'F'.AND.XTIT(I,18).EQ.'Y')LX(3)=I
      IF(XTIT(I,12).EQ.'F'.AND.XTIT(I,18).EQ.'Z')LX(4)=I
      IF(XTIT(I,12).EQ.'U'.OR.XTIT(I,12).EQ.'B'.AND.XTIT(I,13).EQ.'_'.
     1 AND.XTIT(I,14).EQ.'I'.AND.XTIT(I,15).EQ.'S'.AND.XTIT(I,16).
     2 EQ.'O')LX(5)=I
43    CONTINUE
44    CALL READLINE(TIT,IER)
      IF(IER.EQ.1)GO TO 68
      DO 45 I=1,80
      IF(TIT(I).NE.' ')GO TO 46
45    CONTINUE
      GO TO 44
46    IF(TIT(1).EQ.'_')GO TO 52
      DO 47 I=1,5
      IF(TIT(I).NE.LOP(I))GO TO 48
47    CONTINUE
      GO TO 52
48    CALL DECODSTR(TIT,NI,NC,STR1)
      NT=NT+1
      DO 49 L=1,6
49    ATM(NT,L)=STR1(LX(1),L)
      DO 51 K=2,5
      NK=NC(LX(K))
      DO 50 J=1,NK
50    STRR(J)=STR1(LX(K),J)
      CALL STRING1(NK,STRR,AA,DD)
      XX(NT,K-1)=AA
      SX(NT,K-1)=DD
51    CONTINUE
      GO TO 44
52    KX=1
      GO TO 3
      ENDIF
53    CONTINUE
      CALL ATOMSP(NT,ATM)
C-----Atomic displacement parameters
      IF(KU.EQ.1)GO TO 64
      IF(NU.NE.0)THEN
      DO 54 I=1,NU
      IF(UTIT(I,18).EQ.'L'.AND.UTIT(I,19).EQ.'A'.AND.UTIT(I,20).EQ.'B'.
     1 AND.UTIT(I,21).EQ.'E'.AND.UTIT(I,22).EQ.'L')LU(1)=I
      IF(UTIT(I,20).EQ.'1'.AND.UTIT(I,21).EQ.'1')LU(2)=I
      IF(UTIT(I,20).EQ.'2'.AND.UTIT(I,21).EQ.'2')LU(3)=I
      IF(UTIT(I,20).EQ.'3'.AND.UTIT(I,21).EQ.'3')LU(4)=I
      IF(UTIT(I,20).EQ.'2'.AND.UTIT(I,21).EQ.'3')LU(5)=I
      IF(UTIT(I,20).EQ.'1'.AND.UTIT(I,21).EQ.'3')LU(6)=I
      IF(UTIT(I,20).EQ.'1'.AND.UTIT(I,21).EQ.'2')LU(7)=I
54    CONTINUE
55    CALL READLINE(TIT,IER)
      IF(IER.EQ.1)GO TO 68
      DO 56 I=1,80
      IF(TIT(I).NE.' ')GO TO 57
56    CONTINUE
      GO TO 55
57    IF(TIT(1).EQ.'_')GO TO 63
      DO 58 I=1,5
      IF(TIT(I).NE.LOP(I))GO TO 59
58    CONTINUE
      GO TO 63
59    CALL DECODSTR(TIT,NI,NC,STR1)
      NAU=NAU+1
      DO 60 L=1,6
60    ATU(NAU,L)=STR1(LU(1),L)
      DO 62 K=2,7
      NK=NC(LU(K))
      DO 61 J=1,NK
61    STRR(J)=STR1(LU(K),J)
      CALL STRING1(NK,STRR,AA,DD)
      U(NAU,K-1)=AA
62    SU(NAU,K-1)=DD
      GO TO 55
63    KU=1
      GO TO 3
      ENDIF
64    IF(KX.EQ.1.AND.KU.EQ.1)THEN
      K7=1
      GO TO 2
      ELSE
      GO TO 33
      ENDIF
C-----Equivalent positions
65    IF(K8.EQ.1)GO TO 67
      CALL STR3
      K8=1
      GO TO 3
67    IF(K1.EQ.1.AND.K2.EQ.1.AND.K3.EQ.1.AND.K4.EQ.1.AND.K5.EQ.1.AND.
     1 K6.EQ.1.AND.K7.EQ.1.AND.K8.EQ.1)GO TO 68
      GO TO 2
68    CONTINUE
      CALL STR2(NCR,STRB,NA,STRA,FST)
      DO 7 I=1,NA
      CHR1=STRA(1,I)
      CHR2=STRA(2,I)
      CALL LABLAT(CHR1,CHR2)
7     STRA(2,I)=CHR2
      CALL STRAT(NA,STRA,FST,TIT1)
      CALL PREPCOOR
      CLOSE (IN)
      CLOSE (IO)
      STOP
      END
 
      SUBROUTINE INPOUT
C-----Assignes the input and output files
      CHARACTER*14 FILIN,FILOUT
      COMMON/INPOU/IN,IO
      WRITE(*,100)
100   FORMAT(' Key in the input file'/' ?>')
      READ(*,'(A14)')FILIN
      WRITE(*,101)
101   FORMAT(' Key in the output file'/' ?>')
      READ(*,'(A14)')FILOUT
      OPEN(UNIT=IN,FILE=FILIN,FORM='FORMATTED')
      REWIND(UNIT=IN)
      OPEN(UNIT=IO,FILE=FILOUT,FORM='FORMATTED')
      REWIND(UNIT=IO)
      RETURN
      END
 
      SUBROUTINE READLINE(TIT,IER)
      CHARACTER*1 TIT(80),MINU(26),MAIU(26)
      COMMON/INPOU/IN,IO
     1      /MIMA/MINU,MAIU
      IER=0
1     READ(IN,'(80A1)',ERR=4,END=4)TIT
C-----Blanks spurious characters
      CALL ELMSC(TIT)
C-----Skips blank lines
      DO 2 I=1,80
      IF(TIT(I).NE.' ')GO TO 3
2     CONTINUE
      GO TO 1
3     IF(TIT(1).EQ.'#')GO TO 1
C-----All upper case letters
      CALL MINUMA(80,TIT)
C-----Eliminates leading and redundant blanks
      CALL ELIMBLK(TIT)
      GO TO 5
4     IER=1
5     RETURN
      END
 
      SUBROUTINE ELMSC(TIT)
C-----This routine blanks spuriuos characters in a 80 characters string
      CHARACTER*1 TIT(80),NR(10),MAIU(26),MINU(26),SPCR(26)
      COMMON/INPOU/IN,IO
     1      /MIMA/MINU,MAIU
     2      /NRSP/NR,SPCR
      DO 3 I=1,80
      DO 1 J=1,10
      IF(TIT(I).EQ.NR(J))GO TO 3
1     CONTINUE
      DO 2 J=1,26
      IF(TIT(I).EQ.MAIU(J).OR.TIT(I).EQ.MINU(J).OR.TIT(I).EQ.SPCR(J))
     1 GO TO 3
2     CONTINUE
      TIT(I)=' '
3     CONTINUE
      RETURN
      END
 
      SUBROUTINE ADDLINE(TIT,NB)
C-----Add a line of characters to TIT
      CHARACTER*1 TIT(80),TIT1(80)
      COMMON/INPOU/IN,IO
      DO 1 I=NB+2,80
      IF(TIT(I).NE.' ')RETURN
1     CONTINUE
      READ(IN,'(80A1)')TIT1
      CALL ELMSC(TIT1)
      N1=NB+2
      N=80-N1
      DO 2 I=1,N
2     TIT(I+N1)=TIT1(I)
      CALL ELIMBLK(TIT)
      RETURN
      END
 
      SUBROUTINE DECODSTR(STR,NI,NC,STR1)
C-----Decode a string of CIF
      CHARACTER*1 STR(80),STR1(20,60)
      INTEGER NC(20)
      COMMON/INPOU/IN,IO
      DO 1 I=1,20
      DO 1 J=1,60
1     STR1(I,J)=' '
C-----Eliminates redundant blanks
      DO 5 I=1,10
      DO 3 J=1,79
      IF(STR(J).EQ.' '.AND.STR(J+1).EQ.' ')THEN
      DO 2 K=J,79
2     STR(K)=STR(K+1)
      STR(80)=' '
      ENDIF
3     CONTINUE
      IF(STR(1).EQ.' ')THEN
      DO 4 J=1,79
4     STR(J)=STR(J+1)
      ENDIF
5     CONTINUE
C-----Counts the number of items, NI, the number of characters of each
C-----item, NC, and collects all the items in strings, STR1(20,60).
      NI=1
      NC(1)=0
      DO 7 I=1,79
      IF(I.EQ.1)THEN
      NC(I)=1
      STR1(NI,NC(NI))=STR(I)
      GO TO 7
      ENDIF
      IF(STR(I).NE.' ')GO TO 6
      IF(STR(I).EQ.' '.AND.STR(I-1).EQ.' ')THEN
      NI=NI-1
      GO TO 8
      ENDIF
      NI=NI+1
      NC(NI)=0
      GO TO 7
6     NC(NI)=NC(NI)+1
      STR1(NI,NC(NI))=STR(I)
7     CONTINUE
8     RETURN
      END
 
      SUBROUTINE STRING1(N,STR,AA,DD)
C-----Decode a numeric string
      CHARACTER*1 STR(50),STR1(20)
      COMMON/INPOU/IN,IO
C-----Checks the presence of SU and counts characters:
C-----NPP = position of the decimal point
C-----NPR = position of the open parenthesis
C-----NDC = number of decimal digits
C-----NDS = number of characters of the SU
      KD=0
      IF(STR(N).NE.')')THEN
      NPR=N+1
      KD=1
      ELSE
      DO 1 I=1,N-1
      IF(STR(I).EQ.'(')GO TO 2
1     CONTINUE
2     NPR=I
      IF(STR(NPR+1).EQ.'-')STR(NPR+1)='0'
      ENDIF
C-----Decodes the number
      DO 3 I=1,NPR-1
3     STR1(I)=STR(I)
      WRITE(10,*)(STR1(I),I=1,NPR-1)
      BACKSPACE 10
      READ(10,*)AA
      DO 4 I=1,N
      IF(STR(I).EQ.'.')GO TO 5
4     CONTINUE
5     NPP=I
      NDC=(NPR-1)-NPP
      DD=0.0
      IF(KD.EQ.1) GO TO 8
      NDS=(N-1)-NPR
C-----Decodes the standard uncertainty (SU)
      BB=1.0
      DO 6 I=1,(NDC-NDS)
6     BB=BB*1E-1
      DO 7 I=1,NDS
      BB=BB*1E-1
      NN=NMR(STR(NPR+I))
7     DD=DD+NN*BB
8     RETURN
      END
 
      SUBROUTINE STR2(N,STR,NA,STRA,FST)
C-----Decode a formula_sum string
      CHARACTER*1 STR(50),STRA(2,20),STR1(50),STRF(10,20),NUM(11),
     1 ATT(98,2),AA(2),ATM1(20,2)
      DIMENSION FST(20),NP(20),NC(20)
      COMMON/INPOU/IN,IO
     1      /LBL1/ATT
     2      /LBL2/NS
     3      /LBL3/ATM1
      DATA NUM/'0','1','2','3','4','5','6','7','8','9','.'/
C-----Eliminates blanks
      NN=0
      DO 2 K=1,3
      DO 2 I=1,N
      IF(STR(I).EQ.' ')THEN
      DO 1 J=I,N
1     STR(J)=STR(J+1)
      NN=NN+1
      ENDIF
2     CONTINUE
      N=N-NN
C-----Recognizes alphabetic from numeric characters
      DO 3 I=1,50
3     STR1(I)=' '
      DO 4 I=1,10
      DO 4 J=1,20
4     STRF(I,J)=' '
      DO 6 I=1,N
      DO 5 J=1,11
      IF(STR(I).EQ.NUM(J))THEN
      STR1(I)='N'
      GO TO 6
      ENDIF
5     CONTINUE
      STR1(I)='A'
6     CONTINUE
C-----Add missing number (1)
      IF(STR1(N).EQ.'A')THEN
      N=N+1
      STR(N)='1'
      STR1(N)='N'
      ENDIF
      CALL FORMSUM(N,STR,STR1)
C-----Check the absence of numbers and the symbols of atoms
      DO 13 I=3,N
      IF(STR1(I-2).EQ.'A'.AND.STR1(I-1).EQ.'A'.AND.STR1(I).EQ.'A')THEN
      WRITE(*,'(/'' In the _chemical_formula_sum_ there is some atom '',
     1 ''with no number''/'' Check that formula carefully''/)')
      STOP
      ENDIF
      IF(STR1(I-1).EQ.'A'.AND.STR1(I).EQ.'A')THEN
      AA(1)=STR(I-1)
      AA(2)=STR(I)
      CALL MINUMA(2,AA)
      DO 14 J=1,98
      IF(AA(1).NE.ATT(J,1).OR.AA(2).NE.ATT(J,2))GO TO 14
      GO TO 13
14    CONTINUE
      WRITE(*,'(/'' In the _chemical_formula_sum_ there is something '',
     1 ''wrong''/'' with the atom symbols. Check that formula '',
     2 ''carefully''/)')
      STOP
      ENDIF
13    CONTINUE
C-----Counts the number of atoms, NA, and the position, NP, of each atom
C-----in the string
      NA=1
      DO 7 I=2,N
      IF(STR1(I-1).EQ.'N'.AND.STR1(I).EQ.'A')THEN
      NA=NA+1
      NP(NA)=I
      ENDIF
7     CONTINUE
C-----Counts the number, NC, of characters for each atom
      NP(1)=1
      DO 8 I=2,NA
8     NC(I-1)=NP(I)-NP(I-1)
      NC(NA)=N-NP(NA)+1
      DO 11 I=1,NA
      STRA(1,I)=STR(NP(I))
      IF(STR1(NP(I)+1).EQ.'A')THEN
      STRA(2,I)=STR(NP(I)+1)
      DO 9 J=3,NC(I)
9     STRF(J-2,I)=STR(J+NP(I)-1)
      ELSE
      STRA(2,I)=' '
      DO 10 J=2,NC(I)
10    STRF(J-1,I)=STR(J+NP(I)-1)
      ENDIF
      IF(STRF(1,I).EQ.' ')STRF(1,I)='1'
11    CONTINUE
      DO 12 I=1,NA
      WRITE(10,'(10A1)')(STRF(L,I),L=1,10)
      BACKSPACE 10
12    READ(10,*)FST(I)
      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)=' '
      ELSEIF(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 EQP(TIT,NS,STT,NCS)
C-----Extract equivalent position from a TIT string
      CHARACTER*1 TIT(80),STT(25,10),AA,BB
      DIMENSION NCS(10),N1(20),N2(20)
      COMMON/INPOU/IN,IO
      AA=1H'
      BB=1H"
      NS=0
      KK=0
      NI=1
      IF(TIT(1).NE.' ')THEN
      DO 9 K=1,79
9     TIT(80-K+1)=TIT(80-K)
      TIT(1)=' '
      ENDIF
1     DO 3 I=NI,80
      IF(TIT(I).EQ.AA.OR.TIT(I).EQ.BB)KK=KK+1
      IF(MOD(KK,2).NE.0.AND.TIT(I).EQ.' ')THEN
      DO 2 J=I,79
2     TIT(J)=TIT(J+1)
      NI=I
      GO TO 1
      ENDIF
3     CONTINUE
      IF(KK.NE.0)GO TO 6
      DO 4 I=1,80
      IF(TIT(I).EQ.' '.AND.TIT(I+1).NE.' ')THEN
      NS=NS+1
      N1(NS)=I+1
      ENDIF
      IF(TIT(I).NE.' '.AND.TIT(I+1).EQ.' ')N2(NS)=I
4     CONTINUE
      NS=NS-1
      DO 5 K=1,NS
      NCS(K)=N2(K)-N1(K)+1
      DO 5 L=N1(K),N2(K)
5     STT(L-N1(K)+1,K)=TIT(L)
      RETURN
6     DO 7 I=1,80
      IF(TIT(I).EQ.' '.AND.TIT(I+1).EQ.AA.OR.TIT(I).EQ.' '.AND.
     1 TIT(I+1).EQ.BB)THEN
      NS=NS+1
      N1(NS)=I+1
      ENDIF
      IF(TIT(I).EQ.AA.AND.TIT(I+1).EQ.' '.OR.TIT(I).EQ.BB.AND.
     1 TIT(I+1).EQ.' ')N2(NS)=I
7     CONTINUE
      DO 8 K=1,NS
      NCS(K)=N2(K)-N1(K)-1
      DO 8 L=N1(K)+1,N2(K)-1
8     STT(L-N1(K),K)=TIT(L)
      RETURN
      END
 
      SUBROUTINE STR3
C-----Reads the equivalent positions and eliminates the redundants ones
      CHARACTER*1 STG(25,192),STC(25,96),TIT(80),STR(25),STT(25,10),
     1 HMS(30),TIT1(120)
      DIMENSION F(3),FT(3,192),NCS(10)
      INTEGER LE(3,3),LET(3,3,192)
      COMMON/INPOU/IN,IO
     1      /GRP6/HMS,TIT1
     2      /GRP8/IC,NP
     3      /GRP9/STG,STC
      DO 1 I=1,25
      DO 1 J=1,192
1     STG(I,J)=' '
      NP=0
C-----Reads strings
2     READ(IN,'(80A1)',ERR=14,END=14)TIT
      CALL ELMSC(TIT)
      DO 3 I=1,80
      IF(TIT(I).NE.' ')GO TO 4
3     CONTINUE
      GO TO 2
4     DO 5 I=1,80
      IF(TIT(I).EQ.'_'.OR.TIT(I).EQ.'#')THEN
      BACKSPACE IN
      GO TO 14
      ENDIF
5     CONTINUE
      CALL EQP(TIT,NS,STT,NCS)
      DO 10 K=1,NS
      DO 11 L=1,NCS(K)
      STR(L)=STT(L,K)
11    STG(L,NP+K)=STT(L,K)
      DO 12 I=NCS(K)+1,25
12    STR(I)=' '
      CALL DECEQ(STR,LE,F)
      DO 13 I=1,3
      FT(I,NP+K)=F(I)
      DO 13 J=1,3
13    LET(I,J,NP+K)=LE(I,J)
10    CONTINUE
      NP=NP+NS
      GO TO 2
14    IF(HMS(1).EQ.'P')GO TO 20
C-----Eliminate the redundant Bravais equivalent positions
      CALL BRAVEQ(LET,FT)
C-----Looks for centrosymmetric positions
20    NS=0
      DO 19 I=1,NP-1
      DO 16 J=I+1,NP
      DO 15 K=1,3
      DO 15 L=1,3
      IF(LET(K,L,I).NE.-LET(K,L,J))GO TO 16
15    CONTINUE
      GO TO 17
16    CONTINUE
      GO TO 19
17    NS=NS+1
      DO 18 L=1,25
18    STC(L,NS)=STG(L,I)
19    CONTINUE
C     N=NP
      IC=1
      IF(NS.EQ.NP/2)THEN
      NP=NS
      IC=-1
      ENDIF
      RETURN
      END
 
      SUBROUTINE MINUMA(N,STR)
C-----This routine transforms the lower case characters into upper
C-----case characters, in a string of two 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 DECEQ(STR,LE,F)
C-----This routine decodes the equivalent positions
      CHARACTER*1 STR(25),COO(13)
      INTEGER LE(3,3)
      DIMENSION F(3)
      COMMON/INPOU/IN,IO
      DATA COO/'X','Y','Z',',','/','+','-','1','2','3','4','5','6'/
      DO 1 I=1,3
      F(I)=0.0
      DO 1 J=1,3
1     LE(I,J)=0
      NCS=25
      CALL MINUMA(NCS,STR)
      N=0
      DO 2 I=1,24
      IF(STR(I).EQ.' '.AND.STR(I+1).EQ.' ')GO TO 3
      IF(STR(I).NE.COO(4))GO TO 2
      N=N+1
      IF(N.EQ.1)NA=I
      IF(N.EQ.2)NB=I
2     CONTINUE
3     DO 16 K=1,3
      GO TO (4,5,6),K
4     N1=1
      N2=NA-1
      GO TO 7
5     N1=NA+1
      N2=NB-1
      GO TO 7
6     N1=NB+1
      N2=25
7     KS=1
      KD=0
      DO 15 I=N1,N2
      IF(STR(I).EQ.' '.AND.STR(I+1).EQ.' ')GO TO 17
      IF(STR(I).EQ.' ')GO TO 15
      DO 8 J=1,13
      IF(STR(I).EQ.COO(J))GO TO 9
8     CONTINUE
      GO TO 15
9     IF(J.EQ.4)GO TO 15
      IF(J.EQ.7)KS=-1
      IF(J.EQ.5)KD=1
      IF(J.GT.3)GO TO 11
      DO 10 L=1,3
10    IF(K.EQ.L)LE(L,J)=1*KS
      KS=1
      GO TO 15
11    IF(J.LT.8)GO TO 15
      IF(KD.EQ.1)GO TO 13
      DO 12 L=1,3
12    IF(K.EQ.L)F(L)=(J-7)*KS
      KS=1
      GO TO 15
13    DO 14 L=1,3
      IF(K.EQ.L)F(L)=F(L)/(J-7)
14    CONTINUE
      KD=0
15    CONTINUE
16    CONTINUE
17    RETURN
      END
 
      SUBROUTINE ELIMBLK(TIT)
C-----Eliminates leading and redundant blanks
      CHARACTER*1 TIT(80)
      COMMON/INPOU/IN,IO
C-----Eliminates leading blanks
      DO 2 K=1,50
      IF(TIT(1).EQ.' ')THEN
      TIT(80)=' '
      DO 1 I=1,79
1     TIT(I)=TIT(I+1)
      ENDIF
2     CONTINUE
C-----Eliminates redundant blanks
      DO 4 K=1,50
      DO 4 I=1,79
      IF(TIT(I).EQ.' '.AND.TIT(I+1).EQ.' ')THEN
      TIT(80)=' '
      DO 3 J=I,79
3     TIT(J)=TIT(J+1)
      ENDIF
4     CONTINUE
      RETURN
      END
 
      SUBROUTINE LABLAT(CHR1,CHR2)
C-----This routine transforms the second character of an atom label
C-----in a low case character
      CHARACTER*1 MINU(26),MAIU(26),CHR1,CHR2,STRA(2,20)
      COMMON/MIMA/MINU,MAIU
     1      /GRP1/NA,NT,NAU,IZ,Z,KZ
     2      /GRP2/STRA
      DO 1 I=1,NA
      IF(CHR1.EQ.STRA(1,I).AND.CHR2.EQ.STRA(2,I))GO TO 2
1     CONTINUE
      RETURN
2     DO 3 J=1,26
      IF(CHR2.EQ.MAIU(J))CHR2=MINU(J)
3     CONTINUE
      RETURN
      END
 
      BLOCK DATA
      CHARACTER*1 MINU(26),MAIU(26),NR(10),SPCR(26),ATT(98,2)
      COMMON/MIMA/MINU,MAIU
     1      /NRSP/NR,SPCR
     2      /LBL1/ATT
      DATA NR/'0','1','2','3','4','5','6','7','8','9'/
      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'/
C     DATA SPCR/' ','#','.',',',';',':','-','_','\','/','''','`','%',
C    1 '&','(',')','[',']','?','^','~','+','*','<','>','"'/
      DATA SPCR/1H ,1H#,1H.,1H,,1H;,1H:,1H-,1H_,1H\,1H/,1H',1H`,1H%,
     1 1H&,1H(,1H),1H[,1H],1H?,1H^,1H~,1H+,1H*,1H<,1H>,1H"/
      DATA ((ATT(I,J),J=1,2),I=1,52)/'H',' ','H','E','L','I','B','E',
     1 'B',' ','C',' ','N',' ','O',' ','F',' ','N','E','N','A','M','G',
     2 'A','L','S','I','P',' ','S',' ','C','L','A','R','K',' ','C','A',
     3 'S','C','T','I','V',' ','C','R','M','N','F','E','C','O','N','I',
     4 'C','U','Z','N','G','A','G','E','A','S','S','E','B','R','K','R',
     5 'R','B','S','R','Y',' ','Z','R','N','B','M','O','T','C','R','U',
     6 'R','H','P','D','A','G','C','D','I','N','S','N','S','B','T','E'/
      DATA ((ATT(I,J),J=1,2),I=53,98)/'I',' ','X','E','C','S','B','A',
     1 'L','A','C','E','P','R','N','D','P','M','S','M','E','U','G','D',
     2 'T','B','D','Y','H','O','E','R','T','M','Y','B','L','U','H','F',
     3 'T','A','W',' ','R','E','O','S','I','R','P','T','A','U','H','G',
     4 'T','L','P','B','B','I','P','O','A','T','R','N','F','R','R','A',
     5 'A','C','T','H','P','A','U',' ','N','P','P','U','A','M','C','M',
     6 'B','K','C','F'/
      END
 
      FUNCTION NMR(L)
C-----Converts a character in a digit
      CHARACTER*1 L,NR(10),SPCR(26)
      COMMON/INPOU/IN,IO
     1      /NRSP/NR,SPCR
      DO 1 I=1,10
      IF(L.EQ.NR(I))THEN
      NMR=I-1
      RETURN
      ENDIF
1     CONTINUE
      WRITE(IO,'(''The character '',A1,'' does not correspond to a '',
     1 ''digit'')')L
      RETURN
      END
 
      SUBROUTINE PREPCOOR
C-----Sets up the files of coordinates and displacement parameters
C-----saparating hydrogens from non-hydrogen atoms
      CHARACTER*1 ATM(500,6),ATU(500,6),HAT(500,6),STRA(2,20),STR(25),
     1 HMS(30),STG(25,192),STC(25,96),TIT1(120)
      DIMENSION XX(500,4),SX(500,4),U(500,6),SU(500,6),XH(500,4),
     1 SH(500,4),C(3),SC(3),A(3),SA(3),UZR(5)
      COMMON/INPOU/IN,IO
     1      /GRP1/NA,NT,NAU,IZ,Z,KZ
     2      /GRP2/STRA
     3      /GRP3/ATM,ATU
     4      /GRP4/XX,SX
     5      /GRP5/U,SU
     6      /GRP6/HMS,TIT1
     7      /GRP7/C,SC,A,SA,ALA
     8      /GRP8/IC,NE
     9      /GRP9/STG,STC
      NH=0
      IT=1
      DO 4 I=1,NT
      IF(ABS(XX(I,1)).GT.0.75.OR.ABS(XX(I,2)).GT.0.75.OR.
     1 ABS(XX(I,3)).GT.0.75)IT=2
      IF(ATM(I,1).NE.'H')GO TO 4
      DO 1 K=1,NA
      IF(ATM(I,1).EQ.STRA(1,K).AND.ATM(I,2).EQ.STRA(2,K))GO TO 4
1     CONTINUE
      NH=NH+1
      DO 2 L=1,6
2     HAT(NH,L)=ATM(I,L)
      DO 3 K=1,4
      XH(NH,K)=XX(I,K)
      SH(NH,K)=SX(I,K)
3     CONTINUE
4     CONTINUE
      DO 9 JK=1,NH
      DO 9 I=1,NT
      IF(ATM(I,1).NE.'H')GO TO 9
      DO 5 K=1,NA
      IF(ATM(I,1).EQ.STRA(1,K).AND.ATM(I,2).EQ.STRA(2,K))GO TO 9
5     CONTINUE
      DO 8 J=I,499
      DO 6 L=1,6
6     ATM(J,L)=ATM(J+1,L)
      DO 7 K=1,4
      XX(J,K)=XX(J+1,K)
7     SX(J,K)=SX(J+1,K)
8     CONTINUE
9     CONTINUE
      NP=NT-NH
      DO 12 L=1,5
12    UZR(L)=0.0
C-----Write the file for PARST
      WRITE(IO,'(30A1)')HMS
      WRITE(IO,'(I3,'',2.5,4.0,0,0,0,0,0,0,1,1,1,0,1,1,1,1,1,2,0'')')NT
      IF(KZ.EQ.0)THEN
      WRITE(IO,'(I2,I4,F8.5)')NA,IZ,ALA
      ELSE
      WRITE(IO,'(I2,F7.2,F8.5)')NA,IZ,ALA
      ENDIF
      WRITE(IO,'(120A1)')TIT1
      WRITE(IO,'(3(F8.4,1X),3(F5.4,1X),3(F6.2,1X),3(F3.2,1X))')C,SC,A,SA
      WRITE(IO,100)
100   FORMAT('(6A1,6F9.5/6F9.5/6F9.5)')
      DO 15 I=1,NP
      DO 14 J=1,NAU
      DO 13 L=1,6
      IF(ATM(I,L).NE.ATU(J,L))GO TO 14
13    CONTINUE
      WRITE(IO,101)(ATM(I,K),K=1,6),(XX(I,K),K=1,3),(SX(I,K),K=1,3),
     1 (U(I,K),K=1,6),(SU(I,K),K=1,6)
101   FORMAT(6A1,6F9.5/6F9.5/6F9.5)
      GO TO 15
14    CONTINUE
      WRITE(IO,101)(ATM(I,K),K=1,6),(XX(I,K),K=1,3),(SX(I,K),K=1,3),
     1 XX(I,4),UZR,SX(I,4),UZR
15    CONTINUE
      DO 18 I=1,NH
      DO 17 J=1,NAU
      DO 16 L=1,6
      IF(HAT(I,L).NE.ATU(J,L))GO TO 17
16    CONTINUE
      WRITE(IO,101)(HAT(I,K),K=1,6),(XH(I,K),K=1,3),(SH(I,K),K=1,3),
     1 (U(I,K),K=1,6),(SU(I,K),K=1,6)
      GO TO 18
17    CONTINUE
18    WRITE(IO,101)(HAT(I,K),K=1,6),(XH(I,K),K=1,3),(SH(I,K),K=1,3),
     1 XH(I,4),UZR,SH(I,4),UZR
      NK=NE-1
      WRITE(IO,'(3I4)')IC,NK,IT
      IF(NK.EQ.0) RETURN
      DO 21 I=1,NE
      DO 19 L=1,25
      IF(IC.EQ.1) STR(L)=STG(L,I)
19    IF(IC.EQ.-1) STR(L)=STC(L,I)
      CALL MINUMA(25,STR)
      DO 20 L=1,25
      IF(IC.EQ.1) STG(L,I)=STR(L)
20    IF(IC.EQ.-1) STC(L,I)=STR(L)
21    CONTINUE
      IF(IC.EQ.1)THEN
      DO 22 L=1,NE
      IF(STG(1,L).EQ.'X'.AND.STG(2,L).EQ.','.AND.STG(3,L).EQ.'Y'.AND.
     1 STG(4,L).EQ.','.AND.STG(5,L).EQ.'Z') GO TO 22
      IF(STG(1,L).EQ.'+'.AND.STG(2,L).EQ.'X'.AND.STG(3,L).EQ.','.AND.
     1 STG(4,L).EQ.'+'.AND.STG(5,L).EQ.'Y'.AND.STG(6,L).EQ.','.AND.
     1 STG(7,L).EQ.'+'.AND.STG(8,L).EQ.'Z') GO TO 22
      WRITE(IO,'(25A1)')(STG(K,L),K=1,25)
22    CONTINUE
      ELSEIF(IC.EQ.-1)THEN
      DO 23 L=1,NE
      IF(STC(1,L).EQ.'X'.AND.STC(2,L).EQ.','.AND.STC(3,L).EQ.'Y'.AND.
     1 STC(4,L).EQ.','.AND.STC(5,L).EQ.'Z') GO TO 23
      IF(STC(1,L).EQ.'+'.AND.STC(2,L).EQ.'X'.AND.STC(3,L).EQ.','.AND.
     1 STC(4,L).EQ.'+'.AND.STC(5,L).EQ.'Y'.AND.STC(6,L).EQ.','.AND.
     1 STC(7,L).EQ.'+'.AND.STC(8,L).EQ.'Z') GO TO 23
      IF(STC(1,L).EQ.'-'.AND.STC(2,L).EQ.'X'.AND.STC(3,L).EQ.','.AND.
     1 STC(4,L).EQ.'-'.AND.STC(5,L).EQ.'Y'.AND.STC(6,L).EQ.','.AND.
     1 STC(7,L).EQ.'-'.AND.STC(8,L).EQ.'Z') GO TO 23
      WRITE(IO,'(25A1)')(STC(K,L),K=1,25)
23    CONTINUE
      ENDIF
      RETURN
      END
 
      SUBROUTINE ATOMSP(NT,ATM)
C-----Deduce the atomic species from the atom labels
      CHARACTER*1 ATM(500,6),ATM1(20,2),AA,ATT(98,2),
     1 MINU(26),MAIU(26),ATP(500,6)
      COMMON/MIMA/MINU,MAIU
     1      /LBL1/ATT
     2      /LBL2/NA
     3      /LBL3/ATM1
      DO 5 I=1,NT
      ATP(I,1)=ATM(I,1)
      ATP(I,2)=ATM(I,2)
      AA=ATP(I,2)
      CALL MINUMA(1,AA)
      DO 1 L=1,26
      IF(AA.EQ.MAIU(L))GO TO 2
1     CONTINUE
      ATP(I,2)=' '
      GO TO 3
2     ATP(I,2)=AA
3     DO 4 J=1,98
      IF(ATP(I,1).EQ.ATT(J,1).AND.ATP(I,2).EQ.ATT(J,2))GO TO 5
4     CONTINUE
      ATP(I,1)=' '
      WRITE(*,'(/'' Check the labels of the atoms''/)')
5     CONTINUE
      DO 6 I=1,NT-1
      DO 6 J=I+1,NT
      IF(ATP(I,1).EQ.ATP(J,1).AND.ATP(I,2).EQ.ATP(J,2))
     1 ATP(J,1)=' '
6     CONTINUE
      NA=0
      DO 7 I=1,NT
      IF(ATP(I,1).NE.' ')THEN
      NA=NA+1
      ATM1(NA,1)=ATP(I,1)
      ATM1(NA,2)=ATP(I,2)
      ENDIF
7     CONTINUE
      RETURN
      END
 
      SUBROUTINE FORMSUM(N,STR,STR1)
C-----Add the number of atoms (1) in the chemical_formula_sum when
C-----missing
      CHARACTER*1 ATM1(20,2),STR(50),STR1(50),MINU(26),MAIU(26),AA
      COMMON/MIMA/MINU,MAIU
     1      /LBL2/NS
     2      /LBL3/ATM1
C-----Check a sequence of 4 alphabetic character
      DO 6 I=4,N
      IF(STR1(I-3).EQ.'A'.AND.STR1(I-2).EQ.'A'.AND.STR1(I-1).EQ.'A'.
     1 AND.STR1(I).EQ.'A')THEN
      AA=STR(I-2)
      CALL MINUMA(1,AA)
      DO 1 K=1,NS
      IF(STR(I-3).EQ.ATM1(K,1).AND.AA.EQ.ATM1(K,2))GO TO 2
1     CONTINUE
      GO TO 6
2     AA=STR(I)
      CALL MINUMA(1,AA)
      DO 3 K=1,NS
      IF(STR(I-1).EQ.ATM1(K,1).AND.AA.EQ.ATM1(K,2))GO TO 4
3     CONTINUE
      GO TO 6
4     DO 5 K=1,(N-I+2)
      STR(N-K+2)=STR(N-K+1)
      STR1(N-K+2)=STR1(N-K+1)
5     CONTINUE
      N=N+1
      STR(I-1)='1'
      STR1(I-1)='N'
      ENDIF
6     CONTINUE
C-----Check a sequence of 3 alphabetic character
      DO 13 I=3,N
      IF(STR1(I-2).EQ.'A'.AND.STR1(I-1).EQ.'A'.AND.STR1(I).EQ.'A')
     1 THEN
      AA=STR(I-1)
      CALL MINUMA(1,AA)
      DO 7 K=1,NS
      IF(STR(I-2).EQ.ATM1(K,1).AND.AA.EQ.ATM1(K,2))GO TO 9
7     CONTINUE
      DO 8 K=1,NS
      IF(STR(I-2).EQ.ATM1(K,1).AND.ATM1(K,2).EQ.' ')GO TO 11
8     CONTINUE
      GO TO 13
9     DO 10 K=1,(N-I+1)
      STR(N-K+2)=STR(N-K+1)
10    STR1(N-K+2)=STR1(N-K+1)
      N=N+1
      STR(I)='1'
      STR1(I)='N'
      ENDIF
      GO TO 13
11    DO 12 K=1,(N-I+2)
      STR(N-K+2)=STR(N-K+1)
12    STR1(N-K+2)=STR1(N-K+1)
      N=N+1
      STR(I-1)='1'
      STR1(I-1)='N'
13    CONTINUE
C-----Check a sequence of 2 alphabetic character
      DO 18 I=2,N
      IF(STR1(I-1).EQ.'A'.AND.STR1(I).EQ.'A')THEN
      AA=STR(I)
      CALL MINUMA(1,AA)
      DO 14 K=1,NS
      IF(STR(I-1).EQ.ATM1(K,1).AND.AA.EQ.ATM1(K,2))GO TO 18
14    CONTINUE
      DO 15 K=1,NS
      IF(STR(I-1).EQ.ATM1(K,1).AND.ATM1(K,2).EQ.' ')GO TO 16
15    CONTINUE
      GO TO 18
16    DO 17 K=1,(N-I+1)
      STR(N-K+2)=STR(N-K+1)
17    STR1(N-K+2)=STR1(N-K+1)
      N=N+1
      STR(I)='1'
      STR1(I)='N'
      ENDIF
18    CONTINUE
      RETURN
      END
 
      SUBROUTINE BRAVEQ(LET,FT)
C-----Eliminate the redundant Bravais equivalent positions
      CHARACTER*1 STG(25,192),HMS(30),TIT1(120),STG1(25,192),
     1 STC(25,96)
      DIMENSION FT(3,192),FT1(3,192)
      INTEGER LET(3,3,192),NL(96),LET1(3,3,192)
      COMMON/INPOU/IN,IO
     1      /GRP6/HMS,TIT1
     2      /GRP8/IC,NP
     3      /GRP9/STG,STC
      DO 8 I=1,NP-1
      DO 8 J=I+1,NP
      IF(HMS(1).EQ.'I')GO TO 2
      IF(HMS(1).EQ.'F')GO TO 4
      IF(HMS(1).EQ.'R')GO TO 6
C-----Bravais lattices A, B, C
      IF(HMS(1).EQ.'A')THEN
      K1=2
      K2=3
      ELSEIF(HMS(1).EQ.'B')THEN
      K1=1
      K2=3
      ELSEIF(HMS(1).EQ.'C')THEN
      K1=1
      K2=2
      ENDIF
      DO 1 K=1,3
      DO 1 L=1,3
      IF(LET(K,L,I).NE.LET(K,L,J))GO TO 8
1     CONTINUE
      AA=ABS(ABS(FT(K1,I))-ABS(FT(K1,J)))
      IF(AA.GT.1.0)AA=AA-1.0
      BB=ABS(ABS(FT(K2,I))-ABS(FT(K2,J)))
      IF(AA.GT.1.0)AA=AA-1.0
      IF(BB.GT.1.0)BB=BB-1.0
      IF(ABS(0.5-AA).LT.0.1.AND.ABS(0.5-BB).LT.0.1)STG(1,J)='*'
      GO TO 8
C-----Bravais lattice I
2     DO 3 K=1,3
      DO 3 L=1,3
      IF(LET(K,L,I).NE.LET(K,L,J))GO TO 8
3     CONTINUE
      AA=ABS(ABS(FT(1,I))-ABS(FT(1,J)))
      BB=ABS(ABS(FT(2,I))-ABS(FT(2,J)))
      CC=ABS(ABS(FT(3,I))-ABS(FT(3,J)))
      IF(AA.GT.1.0)AA=AA-1.0
      IF(BB.GT.1.0)BB=BB-1.0
      IF(CC.GT.1.0)CC=CC-1.0
      IF(ABS(0.5-AA).LT.0.1.AND.ABS(0.5-BB).LT.0.1.AND.ABS(0.5-CC)
     1 .LT.0.1)STG(1,J)='*'
      GO TO 8
C-----Bravais lattice F
4     DO 5 K=1,3
      DO 5 L=1,3
      IF(LET(K,L,I).NE.LET(K,L,J))GO TO 8
5     CONTINUE
      AA=ABS(ABS(FT(1,I))-ABS(FT(1,J)))
      BB=ABS(ABS(FT(2,I))-ABS(FT(2,J)))
      CC=ABS(ABS(FT(3,I))-ABS(FT(3,J)))
      IF(AA.GT.1.0)AA=AA-1.0
      IF(BB.GT.1.0)BB=BB-1.0
      IF(CC.GT.1.0)CC=CC-1.0
      IF((ABS(0.5-BB).LT.0.1.AND.ABS(0.5-CC).LT.0.1).OR.
     1   (ABS(0.5-AA).LT.0.1.AND.ABS(0.5-CC).LT.0.1).OR.
     2   (ABS(0.5-AA).LT.0.1.AND.ABS(0.5-BB).LT.0.1))STG(1,J)='*'
      GO TO 8
C-----Bravais lattice R
6     DO 7 K=1,3
      DO 7 L=1,3
      IF(LET(K,L,I).NE.LET(K,L,J))GO TO 8
7     CONTINUE
      AA=ABS(ABS(FT(1,I))-ABS(FT(1,J)))
      BB=ABS(ABS(FT(2,I))-ABS(FT(2,J)))
      CC=ABS(ABS(FT(3,I))-ABS(FT(3,J)))
      IF(AA.GT.1.0)AA=AA-1.0
      IF(BB.GT.1.0)BB=BB-1.0
      IF(CC.GT.1.0)CC=CC-1.0
      IF((ABS(0.333-AA).LT.0.1.AND.ABS(0.666-BB).LT.0.1.
     1 AND.ABS(0.666-CC).LT.0.1).OR.
     2 (ABS(0.666-AA).LT.0.1.AND.ABS(0.333-BB).LT.0.1.
     3 AND.ABS(0.333-CC).LT.0.1))STG(1,J)='*'
8     CONTINUE
C-----Eliminate starred equivalent positions
9     NN=0
      DO 11 I=1,NP
      IF(STG(1,I).NE.'*')THEN
      NN=NN+1
      DO 10 L=1,25
10    STG1(L,NN)=STG(L,I)
      DO 13 K=1,3
      FT1(K,NN)=FT(K,I)
      DO 13 J=1,3
13    LET1(K,J,NN)=LET(K,J,I)
      ENDIF
11    CONTINUE
      NP=NN
      DO 15 I=1,NP
      DO 12 L=1,25
12    STG(L,I)=STG1(L,I)
      DO 14 K=1,3
      FT(K,I)=FT1(K,I)
      DO 14 J=1,3
14    LET(K,J,I)=LET1(K,J,I)
15    CONTINUE
      RETURN
      END
