      PROGRAM DSTANTAB
C***********************************************************************
C* Release November 1996                                               *
C*                       Program DSTANTAB                              *
C*                        by M. Nardelli                               *
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*                     ---------------------                           *
C* This routine makes a table of bond distances and angles suitable    *
C* for publication (after a minimum of editing) from the PARST output. *
C* Both cases, thermal parameters and no-thermal parameters, are       *
C* considered.                                                         *
C***********************************************************************
      CHARACTER*1 ATM1(6),ATM2(6),ATM3(6),STR0(6),STR1(6),STR2(6),
     1 STR3(6),LBL1(6),LBL2(6),LBL3(6),CHR2,TIT(80),Q$,STRA(2,20),
     2 STR(50)
      CHARACTER*2 KS
      COMMON/GRP2/IN,IO
     1      /GRP3/KDT,NA
     2      /GRP4/STRA
      DATA (STR1(I),I=1,6)/'B','O','N','D',' ','D'/
      DATA (STR2(I),I=1,6)/'N','U','M','B','E','R'/
      DATA (STR3(I),I=1,6)/'B','O','N','D',' ','A'/
      IN=13
      IO=15
      CALL INTERIO
      NN=6
      WRITE(IO,100)
100   FORMAT(' Table   . Bond distances (A) and angles (deg) with',
     1 ' s.u.''s'/'           in parentheses.'/)
      READ(IN,'(80A1)')TIT
      WRITE(IO,'(1X,80A1)')TIT
      WRITE(*,'('' Were crystal data calculated? Y/N>'')')
      READ(*,'(A1)')Q$
      KDT=0
      IF(Q$.EQ.'Y'.OR.Q$.EQ.'y')KDT=1
      IF(KDT.EQ.0) GO TO 29
      DO 26 I=1,17
26    READ(IN,'(80A1)')TIT
      CALL MINUMA(80,TIT)
      CALL ELIMBLK(TIT)
      DO 30 I=1,50
30    STR(I)=' '
      N=0
      DO 27 I=1,76
      IF(TIT(I).EQ.' '.AND.TIT(I+1).EQ.' '.AND.TIT(I+2).EQ.' '.AND.
     1 TIT(I+3).EQ.' '.AND.TIT(I+4).EQ.' ')GO TO 28
      N=N+1
      STR(N)=TIT(I)
27    CONTINUE
28    CONTINUE
      CALL STRAT(N,STR)
29    WRITE(*,101)
101   FORMAT(' Do you want distances involving hydrogens? Y/N>')
      READ(*,'(A1)')Q$
      KK=0
      IF(Q$.EQ.'Y'.OR.Q$.EQ.'y')KK=1
      WRITE(*,102)
102   FORMAT(' Are thermal parameters considered in the input file?',
     1 ' Y/N>')
      READ(*,'(A1)')Q$
      KDK=0
      IF(Q$.EQ.'Y'.OR.Q$.EQ.'y')KDK=1
1     READ(IN,'(1X,6A1)')STR0
      CALL MINUMA(NN,STR0)
      DO 2 I=1,6
      IF(STR0(I).NE.STR1(I)) GO TO 1
2     CONTINUE
      KN=1
      IF(KDK.EQ.1)KN=3
      DO 3 I=1,KN
3     READ(IN,'(1X,6A1)')STR0
      WRITE(IO,'(1X,'' '')')
4     IF(KDK.EQ.0)GO TO 20
      READ(IN,'(1X,3A1)')(ATM1(I),I=1,3)
      IF(ATM1(1).EQ.'T'.AND.ATM1(2).EQ.'h'.AND.ATM1(3).EQ.'e')GO TO 4
      BACKSPACE(IN)
      READ(IN,103,ERR=7)ATM1,ATM2,D,NSS
103   FORMAT(1X,6A1,3X,6A1,1X,F6.4,1X,I4)
      GO TO 21
20    READ(IN,'(1X,3A1)')(ATM1(I),I=1,3)
      IF(ATM1(1).EQ.'T'.AND.ATM1(2).EQ.'h'.AND.ATM1(3).EQ.'e')GO TO 4
      BACKSPACE(IN)
      READ(IN,104,ERR=7)ATM1,ATM2,D,FSS
104   FORMAT(1X,6A1,3X,6A1,12X,F6.4,4X,F6.4)
21    IF(KK.EQ.1)GO TO 6
      CALL MINUMA(NN,ATM1)
      DO 24 I=1,6
      IF(ATM1(I).NE.STR2(I))GO TO 25
24    CONTINUE
      GO TO 7
25    CALL ENDECO(ATM1,KS)
      IF(KS.EQ.'H ')GO TO 4
      CALL MINUMA(NN,ATM2)
      CALL ENDECO(ATM2,KS)
      IF(KS.EQ.'H ')GO TO 4
6     IF(KDK.EQ.0)GO TO 22
      NS1=NSS
      GO TO 23
22    NS1=(FSS*10000)
23    CHR2=ATM1(2)
      CALL LABLAT(CHR2)
      LBL1(1)=ATM1(1)
      LBL1(2)=CHR2
      LBL1(3)=ATM1(3)
      LBL1(4)=ATM1(4)
      LBL1(5)=ATM1(5)
      LBL1(6)=ATM1(6)
      CHR2=ATM2(2)
      CALL LABLAT(CHR2)
      LBL2(1)=ATM2(1)
      LBL2(2)=CHR2
      LBL2(3)=ATM2(3)
      LBL2(4)=ATM2(4)
      LBL2(5)=ATM2(5)
      LBL2(6)=ATM2(6)
C-----Write bond distances
C-----s.u. < 0.0010
      IF(NS1.LT.10)THEN
      WRITE(IO,105)LBL1,LBL2,D,NS1
105   FORMAT(1X,6A1,' - ',6A1,14X,F6.4,'(',I1,')')
      GO TO 4
      ENDIF
C-----0.0010 < s.u. < 0.0020
      IF(NS1.GE.10.AND.NS1.LT.20)THEN
      WRITE(IO,106)LBL1,LBL2,D,NS1
106   FORMAT(1X,6A1,' - ',6A1,14X,F6.4,'(',I2,')')
      GO TO 4
      ENDIF
C-----0.0020 < s.u. < 0.0094
      IF(NS1.GE.20.AND.NS1.LE.94)THEN
      NS1=(NS1+5)/10
      WRITE(IO,107)LBL1,LBL2,D,NS1
107   FORMAT(1X,6A1,' - ',6A1,14X,F5.3,'(',I1,')')
      GO TO 4
      ENDIF
C-----0.0094 < s.u. < 0.0200
      IF(NS1.GE.94.AND.NS1.LT.200)THEN
      NS1=(NS1+5)/10
      WRITE(IO,108)LBL1,LBL2,D,NS1
108   FORMAT(1X,6A1,' - ',6A1,14X,F5.3,'(',I2,')')
      GO TO 4
      ENDIF
C-----0.0200 < s.u. < 0.0994
      IF(NS1.GE.200.AND.NS1.LT.994)THEN
      NS1=(NS1+50)/100
      WRITE(IO,109)LBL1,LBL2,D,NS1
109   FORMAT(1X,6A1,' - ',6A1,14X,F4.2,'(',I1,')')
      GO TO 4
      ENDIF
C-----0.0994 < s.u. < 0.2000
      IF(NS1.GE.994.AND.NS1.LT.2000)THEN
      NS1=(NS1+50)/100
      WRITE(IO,110)LBL1,LBL2,D,NS1
110   FORMAT(1X,6A1,' - ',6A1,14X,F4.2,'(',I2,')')
      GO TO 4
      ENDIF
C-----0.2000 < s.u.
      IF(NS1.GE.2000)THEN
      NS1=(NS1+500)/1000
      WRITE(IO,111)LBL1,LBL2,D,NS1
111   FORMAT(1X,6A1,' - ',6A1,14X,F3.1,'(',I1,')')
      ENDIF
      GO TO 4
7     WRITE(*,112)
112   FORMAT(' Do you want angles involving hydrogens? Y/N>')
      READ(*,'(A1)')Q$
      KK=0
      IF(Q$.EQ.'Y'.OR.Q$.EQ.'y')KK=1
14    READ(IN,'(1X,6A1)')STR0
      CALL MINUMA(NN,STR0)
      DO 13 I=1,6
      IF(STR0(I).NE.STR3(I)) GO TO 14
13    CONTINUE
      DO 8 I=1,2
8     READ(IN,'(1X,6A1)')STR0
      WRITE(IO,'(1X,'' '')')
9     READ(IN,113)ATM1,ATM2,ATM3,T,ST
113   FORMAT(1X,6A1,2X,6A1,2X,6A1,11X,F6.2,3X,F6.2)
      CALL MINUMA(NN,ATM1)
      DO 5 I=1,6
      IF(ATM1(I).NE.STR2(I))GO TO 10
5     CONTINUE
      GO TO 12
10    IF(KK.EQ.1)GO TO 15
      CALL ENDECO(ATM1,KS)
      IF(KS.EQ.'H ')GO TO 9
      CALL MINUMA(NN,ATM2)
      CALL ENDECO(ATM2,KS)
      IF(KS.EQ.'H ')GO TO 9
      CALL MINUMA(NN,ATM3)
      CALL ENDECO(ATM3,KS)
      IF(KS.EQ.'H ')GO TO 9
15    NST=ST*100
      CHR2=ATM1(2)
      CALL LABLAT(CHR2)
      LBL1(1)=ATM1(1)
      LBL1(2)=CHR2
      LBL1(3)=ATM1(3)
      LBL1(4)=ATM1(4)
      LBL1(5)=ATM1(5)
      LBL1(6)=ATM1(6)
      CHR2=ATM2(2)
      CALL LABLAT(CHR2)
      LBL2(1)=ATM2(1)
      LBL2(2)=CHR2
      LBL2(3)=ATM2(3)
      LBL2(4)=ATM2(4)
      LBL2(5)=ATM2(5)
      LBL2(6)=ATM2(6)
      CHR2=ATM3(2)
      CALL LABLAT(CHR2)
      LBL3(1)=ATM3(1)
      LBL3(2)=CHR2
      LBL3(3)=ATM3(3)
      LBL3(4)=ATM3(4)
      LBL3(5)=ATM3(5)
      LBL3(6)=ATM3(6)
C-----Write bond angles
C-----s.u. < 0.10
      IF(NST.LT.10)THEN
      WRITE(IO,114)LBL1,LBL2,LBL3,T,NST
114   FORMAT(1X,6A1,'-',6A1,'-',6A1,7X,F6.2,'(',I1,')')
      GO TO 9
      ENDIF
C-----0.10 < s.u. < 0.20
      IF(NST.GE.10.AND.NST.LT.20)THEN
      WRITE(IO,115)LBL1,LBL2,LBL3,T,NST
115   FORMAT(1X,6A1,'-',6A1,'-',6A1,7X,F6.2,'(',I2,')')
      GO TO 9
      ENDIF
C-----0.20 < s.u. < 0.094
      IF(NST.GE.20.AND.NST.LE.94)THEN
      NST=(NST+5)/10
      WRITE(IO,116)LBL1,LBL2,LBL3,T,NST
116   FORMAT(1X,6A1,'-',6A1,'-',6A1,7X,F5.1,'(',I1,')')
      GO TO 9
      ENDIF
C-----0.094 < s.u. < 0.200
      IF(NST.GE.94.AND.NST.LT.200)THEN
      NST=(NST+5)/10
      WRITE(IO,117)LBL1,LBL2,LBL3,T,NST
117   FORMAT(1X,6A1,'-',6A1,'-',6A1,7X,F5.1,'(',I2,')')
      GO TO 9
      ENDIF
C-----0.200 < s.u. < 0.994
      IF(NST.GE.200.AND.NST.LT.994)THEN
      NST=(NST+50)/100
      NGA=(T+0.5)
      WRITE(IO,118)LBL1,LBL2,LBL3,NGA,NST
118   FORMAT(1X,6A1,'-',6A1,'-',6A1,7X,I3,'(',I1,')')
      GO TO 9
      ENDIF
C-----1.000 < s.u.
      IF(NST.GE.994)THEN
      NST=(NST+50)/100
      NGA=(T+0.5)
      WRITE(IO,119)LBL1,LBL2,LBL3,NGA,NST
119   FORMAT(1X,6A1,'-',6A1,'-',6A1,7X,I3,'(',I2,')')
      ENDIF
      GO TO 9
12    STOP
      END
 
      SUBROUTINE INTERIO
C-----Open the input and output files
      CHARACTER*14 FILIN,FILOU
      COMMON/GRP2/IN,IO
      WRITE(*,100)
100   FORMAT(' Key in the input file'/' ?>')
      READ(*,'(A)')FILIN
      OPEN(UNIT=IN,FILE=FILIN,FORM='FORMATTED')
      REWIND(UNIT=IN)
      WRITE(*,101)
101   FORMAT(' Key in the output file'/' ?>')
      READ(*,'(A)')FILOU
      OPEN(UNIT=IO,FILE=FILOU,FORM='FORMATTED')
      REWIND(UNIT=IO)
      RETURN
      END
 
      SUBROUTINE MINUMA(N,STR)
C-----This routine transforms the lower case characters into upper
C-----case characters, in a string of four characters
      CHARACTER*1 MINU(26),MAIU(26),STR(N)
      COMMON/GRP1/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 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 ENDECO(ATOM,KS)
C-----Transfer in KS a two character symbol of an atom
      CHARACTER*1 ATOM(6),ATOM1(6),MINU(26),MAIU(26),STRA(2,20)
      CHARACTER*2 KS,RS
      COMMON/GRP1/MINU,MAIU
     1      /GRP3/KDT,NA
     2      /GRP4/STRA
      EQUIVALENCE (RS,ATOM1(1))
      DO 1 I=1,6
1     ATOM1(I)=ATOM(I)
      IF(KDT.EQ.1)GO TO 3
      DO 2 K=1,26
      IF(ATOM1(2).NE.MAIU(K))GO TO 2
      GO TO 6
2     CONTINUE
      GO TO 5
3     DO 4 I=1,NA
      IF(ATOM1(1).EQ.STRA(1,I).AND.ATOM1(2).EQ.STRA(2,I))GO TO 6
4     CONTINUE
5     ATOM1(2)=' '
6     KS=RS
      RETURN
      END
 
      SUBROUTINE LABLAT(CHR2)
C-----This routine transforms the second character of an atom label
C-----in a low case character
      CHARACTER*1 MINU(26),MAIU(26),CHR2
      COMMON/GRP1/MINU,MAIU
      DO 1 J=1,26
      IF(CHR2.EQ.MAIU(J)) CHR2=MINU(J)
1     CONTINUE
      RETURN
      END
 
      SUBROUTINE STRAT(N,STR)
C-----Decode a chemical formula string
      CHARACTER*1 STR(50),STRA(2,20),STR1(50),STRF(10,20),NUM(11)
      DIMENSION NP(20),NC(20)
      COMMON/GRP2/IN,IO
     1      /GRP3/KDT,NA
     2      /GRP4/STRA
      DATA NUM/'0','1','2','3','4','5','6','7','8','9','.'/
C-----Eliminates blanks
      NN=0
      DO 2 I=1,N
      IF(STR(I).EQ.' ')THEN
      DO 1 J=I,N-1
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-----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)
      ELSE
      STRA(2,I)=' '
      ENDIF
11    CONTINUE
      RETURN
      END
 
      BLOCK DATA
      CHARACTER*1 MINU(26),MAIU(26)
      COMMON/GRP1/MINU,MAIU
      COMMON/GRP2/IN,IO
      DATA IN,IO/13,15/
      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
