PROGRAM GOIN IMPLICIT REAL*4(A-H,O-Z) IMPLICIT INTEGER*4(I-N) PARAMETER (MX=4000,MENDELEV=89) DIMENSION X(MX),IX(MX),amas(MENDELEV) CHARACTER*4 CODE,s4 CHARACTER*1 OK logical lex data amas/1.008,4.003, 2 6.941, 9.012, 10.810,12.011,14.007,15.999,18.998,20.179, 3 22.990,24.305, 26.981,28.086,30.974,32.060,35.453,39.948, 4 39.098,40.080,44.956,47.900,50.941,51.996,54.938,55.847, 4 58.933,58.700,63.546,65.380, 4 69.720,72.590,74.922,78.960,79.904,83.800, 5 85.468,87.620,88.906,91.220,92.906,95.940,98.906,101.070, 5 102.906,106.400,107.868,112.410, 5 114.82,118.69,121.75,127.600,126.905,131.300, 6 132.905,137.330,138.906, 6 140.120,140.908,144.240,145.000,150.400, 6 151.960,157.250,158.925,162.500,164.930,167.260,168.934, 6 173.040,174.970, 6 178.490,180.948,183.850,186.207,190.200,192.220,195.090, 6 196.967,207.590,204.370,207.200,208.980,210.000,210.001, 6 222.02, 7 223.000,226.025,227.028/ real*4,allocatable::A0(:),wexp(:),wcal(:),r(:,:),Q(:) integer*4,allocatable::ITY(:) IX=0 WRITE(*,600) 600 format(' This program makes input for FTRY ',/, 1 ' INPUT FILES: FILE.X',/, 1 ' B.MAT',/, 1 ' (STABLE.TXT)',/,/, 1 ' OUTPUT : FTRY.INP',/,/) if(iargc().eq.0)then WRITE(*,*)' AUTOMATIC RUN (y/n)?' READ(*,'(A)')OK else call getarg(1,OK) endif CODE='INTY' IF(OK.EQ.'y'.OR.OK.EQ.'Y')THEN CODE='AUTO' WRITE(*,*)'Use the scale factor to define the range ' ENDIF if(iargc().gt.1)then call getarg(2,s4) read(s4,*)N else WRITE(*,*)' NUMBER OF THE SCALE FACTORS :' READ(*,*)N endif DO 1 I=1,N WRITE(*,222)I 222 FORMAT(I4,'. factor :') READ(*,*)X(I) WRITE(*,3333) 3333 FORMAT(' MULTIPLY UP TO THE COORDINATE NUMBER :') IK=0 IF (I.GT.1)IK=IX(I-1)+1 IF (I.GT.1)WRITE(*,4444)IK 4444 FORMAT(' (FROM THE COORDINATE ',I4,')') READ(*,*)IX(I) 1 CONTINUE WRITE(*,*)' FTRY.INP ... INPUT FOR FTRY' c OPEN(7,FILE='FTRY.INP') c conserve some obsolete options on line 1: WRITE(7,1111)CODE,0,1,0,1,0,1,0,1,IX(N) 1111 FORMAT(A4,9I4) WRITE(7,333)N 333 FORMAT(20I4) WRITE(7,444)(X(I),I=1,N) 444 FORMAT(6F12.6) WRITE(7,333)(IX(I),I=1,N) OPEN(4,FILE='FILE.X') READ(4,*) READ(4,*)NAT WRITE(*,*)NAT,' ATOMS FOUND IN FILE.X' if(NAT.gt.MX)call report('too many atoms') allocate(r(NAT,3),ITY(NAT),Q(NAT)) do 40 i=1,nat READ(4,*)ITY(i),(r(i,j),j=1,3),(Q(i),j=4,11) if(ITY(i).lt.1.or.ITY(i).gt.MENDELEV)then write(6,*)ITY(i) call report('unknown atomic number') else X(I)=amas(ITY(i)) endif 40 continue close(4) 2 if(iargc().gt.2)then call getarg(3,s4) read(s4,*)ISUB else WRITE(6,601) 601 format('HOW MANY ISOTOPIC SUBSTITUTIONS', 1 ' (negative for auto-deuteration)?') READ(*,*)ISUB endif if(ISUB.gt.0)then DO 5 II=1,ISUB WRITE(*,*)' H 1.007825, D 2.0140, T 3.01605' WRITE(*,*)' C12 12.0, C13 13.003355, N14 14.003074' WRITE(*,*)' N15 15.000108, O16 15.994915, O17 16.999131' WRITE(*,*)' O18 17.999160, F 18.998403, CL35 34.968852' WRITE(*,*)' CL37 36.965903, P 30.973762, S 31.972070' WRITE(*,*)' GIVE NUMBER OF THE ATOM AND THE NEW MASS' READ(*,*)I,X(I) 5 CONTINUE endif c Substitute all acidic Hs by Ds: if(ISUB.lt.0)then ND=0 do 8 i=1,NAT a=r(i,1) y=r(i,2) z=r(i,3) if(ITY(i).eq.1)then do 3 j=1,NAT it=ITY(j) dd=sqrt((a-r(j,1))**2+(y-r(j,2))**2+(z-r(j,3))**2) if(it.eq.7.or.it.eq.8.or.it.eq.9.or.it.eq.16.or.it.eq.17.or. 1 it.eq.35.or.it.eq.53)then if(dd.lt.1.23)then ND=ND+1 X(i)=2.014000 endif endif 3 continue endif 8 continue write(6,7009)ND 7009 format(i5,' acidic hydrogens have been substituted by deuteria') endif DO 6 I=1,NAT,3 IF(NAT-I.GE.2)WRITE(*,6676)I,X(I),I+1,X(I+1),I+2,X(I+2) IF(NAT-I.EQ.1)WRITE(*,6676)I,X(I),I+1,X(I+1) IF(NAT-I.EQ.0)WRITE(*,6676)I,X(I) 6 CONTINUE 6676 FORMAT(3(5X,I5,F12.6)) if(iargc().gt.3)then call getarg(4,OK) else WRITE(*,*)'IS THIS CORRECT (Y/N) ?' READ(*,'(A)')OK endif IF ((OK.EQ.'n').OR.(OK.EQ.'N')) GOTO 2 WRITE(7,444)(Q(I),I=1,NAT) I1=1 WRITE(7,333)I1 WRITE(7,444)(X(I),I=1,NAT) WRITE(7,*) open(71,file='B.MAT') read(71,*)NOB write(6,*)NOB,' internal coordinates' close(71) allocate(A0(NOB)) A0=0. inquire(file='STABLE.TXT',exist=lex) if(lex)then inquire(file='FPC.TAB',exist=lex) if(lex)then write(6,602) 602 format(' STABLE.TXT abd FPC.TAB found,', 1 ' use them for frequency estimation (y/n)?',$) read(5,*)ok if(ok.eq.'y'.or.ok.eq.'Y')then ns=nl('STABLE.TXT') write(6,*)ns,' frequencies in STABLE.TXT' allocate(wexp(ns),wcal(ns)) open(11,file='STABLE.TXT') do 11 i=1,ns 11 read(11,*)wexp(i),wcal(i) close(11) nf=nl('FPC.TAB')-4 write(6,*)nf,' frequencies in FPC.TAB' open(11,file='FPC.TAB') read(11,*) read(11,*) read(11,*) do 12 i=1,min(nf,NOB) read(11,*)A0(i),A0(i) do 13 j=1,ns-1 a1=wcal(j) a2=wcal(j+1) if((A0(i).ge.a1.and.A0(i).le.a2).or. 1 (A0(i).ge.a2.and.A0(i).le.a1))then e1=wexp(j) e2=wexp(j+1) A0(i)=((e2-e1)*A0(i)+a2*e1-a1*e2)/(a2-a1) goto 12 endif 13 continue 12 continue close(11) endif endif endif WRITE(7,444)(A0(I),I=1,NOB) CLOSE(7) WRITE(*,*)' PROGRAM TERMINATED' END function nl(f) c number of lines in a file implicit none character*(*) f integer*4 nl,n open(9,file=f) n=0 1 read(9,*,end=99,err=99) n=n+1 goto 1 99 close(9) nl=n return end subroutine report(s) character*(*) s write(6,*)s stop end