C C $Id: intpr.F,v 1.3 1998/07/16 16:40:02 jjv5 Exp $ C C------------------------------------------------------------------------ C C routines to handle the external parameters C C input format: C C DATA NAME(...) / ... / C NAME(...) / .... / C NAME(...) = .... C C comment is preceded by a 'C' in the first column C C written by Arjan van der Vaart, May 1998 C subroutine intpr(in, ierror) implicit double precision(a-h,o-z) #include "divcon.dim" #include "divcon.h" dimension index(maxindex) character*80 line, name logical empty CC--------------------------------------------CC C the external file does not have to contain all the C parameters, so we need to initialize them (done by C the NOTNAMED=.. keyword) if (notnamed.eq.0) then C . initialize them to zero, NOTNAMED was not used C-RDC write(iout,'(/" ** WARNING **", C-RDC & /" INITIALIZED EXTERNAL PARAMETERS TO ZERO.", C-RDC & /" (THE NOTNAMED-KEYWORD WAS NOT ENCOUNTERED)")') do iat=1,83 do l=0,2 ucore4(l,iat) = 0.0 expnt4(l,iat) = 0.0 al4(l,iat) = 0.0 if(l.ne.0) dl4(l,iat) = 0.0 beta4(l,iat) = 0.0 enddo gss4(iat) = 0.0 gpp4(iat) = 0.0 gsp4(iat) = 0.0 gp24(iat) = 0.0 hsp4(iat) = 0.0 acore4(iat) = 0.0 do igaus=1,4 agaus4(igaus,iat) = 0.0 bgaus4(igaus,iat) = 0.0 cgaus4(igaus,iat) = 0.0 enddo eeatm4(iat) = 0.0 hfatm4(iat) = 0.0 enddo epepmx4 = 0.0 elseif (notnamed.eq.1) then C . initialize them to MNDO values C-RDC write(iout,'(/" INITIALIZED EXTERNAL PARAMETERS TO MNDO ", C-RDC & "VALUES.")') do iat=1,83 do l=0,2 ucore4(l,iat) = ucore1(l,iat) expnt4(l,iat) = expnt1(l,iat) al4(l,iat) = al1(l,iat) if(l.ne.0) dl4(l,iat) = dl1(l,iat) beta4(l,iat) = beta1(l,iat) enddo gss4(iat) = gss1(iat) gpp4(iat) = gpp1(iat) gsp4(iat) = gsp1(iat) gp24(iat) = gp21(iat) hsp4(iat) = hsp1(iat) acore4(iat) = acore1(iat) C . MNDO doesn't have the agaus,bgaus and cgaus parameters: C . initialize them to zero. do igaus=1,4 agaus4(igaus,iat) = 0.0 bgaus4(igaus,iat) = 0.0 cgaus4(igaus,iat) = 0.0 enddo eeatm4(iat) = eeatm1(iat) hfatm4(iat) = hfatm1(iat) enddo epepmx4 = epepmx1 elseif (notnamed.eq.2) then C . initialize them to AM1 values C-RDC write(iout,'(/" INITIALIZED EXTERNAL PARAMETERS TO AM1 ", C-RDC & "VALUES.")') do iat=1,83 do l=0,2 ucore4(l,iat) = ucore2(l,iat) expnt4(l,iat) = expnt2(l,iat) al4(l,iat) = al2(l,iat) if(l.ne.0) dl4(l,iat) = dl2(l,iat) beta4(l,iat) = beta2(l,iat) enddo gss4(iat) = gss2(iat) gpp4(iat) = gpp2(iat) gsp4(iat) = gsp2(iat) gp24(iat) = gp22(iat) hsp4(iat) = hsp2(iat) acore4(iat) = acore2(iat) do igaus=1,4 agaus4(igaus,iat) = agaus2(igaus,iat) bgaus4(igaus,iat) = bgaus2(igaus,iat) cgaus4(igaus,iat) = cgaus2(igaus,iat) enddo eeatm4(iat) = eeatm2(iat) hfatm4(iat) = hfatm2(iat) enddo epepmx4 = epepmx2 elseif (notnamed.eq.3) then C . initialize them to PM3 values C-RDC write(iout,'(/" INITIALIZED EXTERNAL PARAMETERS TO PM3 ", C-RDC & "VALUES.")') do iat=1,83 do l=0,2 ucore4(l,iat) = ucore3(l,iat) expnt4(l,iat) = expnt3(l,iat) al4(l,iat) = al3(l,iat) if(l.ne.0) dl4(l,iat) = dl3(l,iat) beta4(l,iat) = beta3(l,iat) enddo gss4(iat) = gss3(iat) gpp4(iat) = gpp3(iat) gsp4(iat) = gsp3(iat) gp24(iat) = gp23(iat) hsp4(iat) = hsp3(iat) acore4(iat) = acore3(iat) do igaus=1,4 agaus4(igaus,iat) = agaus3(igaus,iat) bgaus4(igaus,iat) = bgaus3(igaus,iat) cgaus4(igaus,iat) = cgaus3(igaus,iat) enddo eeatm4(iat) = eeatm3(iat) hfatm4(iat) = hfatm3(iat) enddo epepmx4 = epepmx3 endif C process the external file lineno = 0 nparam = 0 iend = 80 10 read(in,'(A80)',end=1000) line(1:80) lineno = lineno + 1 call upcase1(line,iend) if (line(1:1).eq.'C') goto 10 call getvalue(line, name, nindex, index, value, empty, ierror) if (empty) goto 10 if (ierror.eq.2) then C-RDC write(iout,'(" SYNTAX ERROR LINE ",I8," OF ",A20, C-RDC & /" :: TOO MANY INDICES")') lineno,fname(26) return elseif (ierror.eq.1) then C-RDC write(iscr,'(" SYNTAX ERROR LINE ",i8," OF ",A20)') C-RDC & lineno,fname(26) return endif call assign(name, nindex, index, value, ierror) if (ierror.ne.0) then C-RDC write(iout,'(" ERROR ASSIGNING VALUE TO ",A20, C-RDC & "... LINE ",I8," OF ",A20, C-RDC & /" NON-EXISTING PARAMETER OR ILL-DEFINED PARAMETER")') C-RDC & name(1:20), lineno, fname(26) ierror = 1 return endif nparam = nparam + 1 goto 10 1000 continue C-RDC 1000 write(iout,'(/" READ ",I8," EXTERNAL PARAMETERS FROM ",A20)') C-RDC & nparam, fname(26) return end CC--------------------------------------------CC CC--------------------------------------------CC subroutine getvalue(line, name, nindex, index, value, empty, & ierror) implicit double precision(a-h,o-z) #include "divcon.dim" #include "divcon.h" dimension index(maxindex) character*80 line, name logical char, num, parl, parr, comma, eq, white, empty, & notnum CC--------------------------------------------CC empty = .false. nindex = 0 ib = 0 ie = 1 C allowed structure: C DATA NAME(...) / ... / C NAME(...) / .... / C NAME(...) = .... C either get DATA or NAME do i=1,80 call whatis7(line(i:i),char,num,parl,parr,comma,eq,white) if (char) then ib = i goto 20 endif enddo 20 if (ib.eq.0) then empty = .true. return endif do i=ib+1,80 call whatis7(line(i:i),char,num,parl,parr,comma,eq,white) if (white) then ie = i-1 goto 30 elseif (parl.or.eq) then ie = i-1 goto 50 endif enddo 30 if (line(ib:ie).eq.'DATA') then do i=ie+1,80 call whatis7(line(i:i),char,num,parl,parr,comma,eq,white) if (char) then ib = i goto 40 endif enddo 40 do i=ib+1,80 call whatis7(line(i:i),char,num,parl,parr,comma,eq,white) if (white.or.parl.or.eq) then ie = i-1 goto 50 endif enddo endif 50 name = line(ib:ie) ib = ie+2 C get INDICES if (parl) then notnum = .true. do i=ie+2,80 call whatis7(line(i:i),char,num,parl,parr,comma,eq,white) if (white.and.notnum) then notnum = .true. ib = i+1 elseif (num) then notnum = .false. ie = i elseif (comma) then nindex = nindex + 1 if (nindex.gt.maxindex) then ierror = 2 return endif if (ib.gt.ie) then ierror = 1 return endif call getinum(line,ib,ie,index(nindex),ierror) if (ierror.ne.0) return notnum = .true. ib = i+1 elseif (parr) then if (ib.le.ie) then nindex = nindex + 1 if (nindex.gt.maxindex) then ierror = 2 return endif call getinum(line,ib,ie,index(nindex),ierror) endif ib = i+1 goto 60 endif enddo endif C get VALUE 60 do i=ib,80 call whatis1(line(i:i),num) if (num) then ib = i goto 70 endif enddo 70 do i=ib+1,80 call whatis1(line(i:i),num) if (.not.num) then ie = i-1 goto 80 endif enddo 80 call getnum(line,ib,ie,value,ierror) end CC--------------------------------------------CC CC--------------------------------------------CC