      PROGRAM TORSTAB
C************************************************************************
C* Release November 1996                                                *
C*                       Program TORSTAB                                *
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 torsion angles suitable for deposition *
C* (after a minimum of editing) from the PARST output. Both cases,      *
C* thermal parameters and no-thermal parameters, are considered         *
C*                                                                      *
C************************************************************************
      CHARACTER*1 ATM1(6),ATM2(6),ATM3(6),ATM4(6),STR0(6),STR2(6),
     1 STR3(6),LBL1(6),LBL2(6),LBL3(6),CHR2,TIT(80),Q$,STRA(2,20),
     2 STR(50),LBL4(6)
      CHARACTER*2 KS
      CHARACTER*24 STRT,STRS
      COMMON/GRP2/IN,IO
     1      /GRP3/KDT,NA
     2      /GRP4/STRA
      DATA STR2/'N','U','M','B','E','R'/
      STRS='TORSION ANGLES (DEGREES)'
      CALL INTERIO
      WRITE(IO,100)
100   FORMAT(' TABLE FOR DEPOSITION'/1X,20('=')/)
      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(IO,'('' '')')
      WRITE(*,101)
101   FORMAT(' Do you want torsion angles involving hydrogens? Y/N>')
      READ(*,'(A1)')Q$
      KK=0
      IF(Q$.EQ.'Y'.OR.Q$.EQ.'y')KK=1
1     READ(IN,'(1X,A24)')STRT
      N=24
      CALL MINUMA(N,STRT)
      IF(STRT.NE.STRS) GO TO 1
      WRITE(IO,'(1X,A24)')STRT
      DO 2 I=1,2
      READ(IN,'(80A1)')TIT
2     WRITE(IO,'(80A1)')TIT
      READ(IN,'(80A1)')TIT
      WRITE(IO,'('' '')')
3     READ(IN,102,ERR=7)ATM1,ATM2,ATM3,ATM4,T,ST
102   FORMAT(1X,4(6A1,1X),4X,2(2X,F7.2))
      N=4
      CALL MINUMA(N,ATM1)
      DO 4 I=1,4
4     IF(ATM1(I).NE.STR2(I))GO TO 5
      GO TO 7
5     IF(KK.EQ.1)GO TO 6
      CALL ENDECO(ATM1,KS)
      IF(KS.EQ.'H ')GO TO 3
      CALL MINUMA(N,ATM2)
      CALL ENDECO(ATM2,KS)
      IF(KS.EQ.'H ')GO TO 3
      CALL MINUMA(N,ATM3)
      CALL ENDECO(ATM3,KS)
      IF(KS.EQ.'H ')GO TO 3
      CALL MINUMA(N,ATM4)
      CALL ENDECO(ATM4,KS)
      IF(KS.EQ.'H ')GO TO 3
6     NST=(ST+0.05)*10
      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)
      CHR2=ATM4(2)
      CALL LABLAT(CHR2)
      LBL4(1)=ATM4(1)
      LBL4(2)=CHR2
      LBL4(3)=ATM4(3)
      LBL4(4)=ATM4(4)
      LBL4(5)=ATM4(5)
      LBL4(6)=ATM4(6)
      IF(NST.LT.10) WRITE(IO,103)LBL1,LBL2,LBL3,LBL4,T,NST
103   FORMAT(1X,3(6A1,'-'),6A1,5X,F7.1,'(',I1,')')
      IF(NST.GE.10.AND.NST.LT.100) WRITE(IO,104)LBL1,LBL2,LBL3,LBL4,
     1 T,NST
104   FORMAT(1X,3(6A1,'-'),6A1,5X,F7.1,'(',I2,')')
      IF(NST.GE.100.AND.NST.LT.1000) WRITE(IO,105)LBL1,LBL2,LBL3,LBL4,
     1 T,NST
105   FORMAT(1X,3(6A1,'-'),6A1,5X,F7.1,'(',I3,')')
      GO TO 3
7     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 N 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/GRP2/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
