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