SUBROUTINE NMDIMB(X,Y,Z,NAT3,BNBND,BIMAG,LNOMA,AMASS,DDS,DDSCR,
1 PARDDV,DDV,DDM,PARDDF,DDF,PARDDE,DDEV,DD1BLK,
2 DD1BLL,NADD,LRAISE,DD1CMP,INBCMP,JNBCMP,
3 NPAR,ATMPAR,ATMPAS,BLATOM,PARDIM,NFREG,NFRET,
4 PARFRQ,CUTF1,ITMX,TOLDIM,IUNMOD,IUNRMD,
5 LBIG,LSCI,ATMPAD,SAVF,NBOND,IB,JB,DDVALM)
IMPLICIT NONE
LOGICAL LOWER,QLONGL
INTEGER MXSTRM,POUTU
PARAMETER (MXSTRM=20,POUTU=6)
INTEGER NSTRM,ISTRM,JSTRM,OUTU,PRNLEV,WRNLEV,IOLEV
COMMON /CASE/ LOWER, QLONGL
COMMON /STREAM/ NSTRM,ISTRM,JSTRM(MXSTRM),OUTU,PRNLEV,WRNLEV,IOLEV
INTEGER LARGE,MEDIUM,SMALL,REDUCE
PARAMETER (LARGE=60120, MEDIUM=25140, SMALL=6120)
PARAMETER (REDUCE=15000)
INTEGER SIZE
PARAMETER (SIZE=MEDIUM)
integer MAXDEFI
parameter(MAXDEFI=250)
INTEGER NAME0,NAMEQ0,NRES0,KRES0
PARAMETER (NAME0=4,NAMEQ0=10,NRES0=4,KRES0=4)
integer MaxAtN
parameter (MaxAtN=55)
INTEGER MAXAUX
PARAMETER (MAXAUX = 10)
INTEGER MAXCSP, MAXHSET
PARAMETER (MAXHSET = 200)
PARAMETER (MAXCSP = 500)
INTEGER MAXHCM,MAXPCM,MAXRCM
PARAMETER (MAXHCM=500)
PARAMETER (MAXPCM=5000)
PARAMETER (MAXRCM=2000)
INTEGER MXCMSZ
PARAMETER (MXCMSZ = 5000)
INTEGER CHRSIZ
PARAMETER (CHRSIZ = SIZE)
INTEGER MAXATB
PARAMETER (MAXATB = 200)
INTEGER MAXVEC
PARAMETER (MAXVEC = 10)
INTEGER IATBMX
PARAMETER (IATBMX = 8)
INTEGER MAXHB
PARAMETER (MAXHB = 8000)
INTEGER MAXTRN,MAXSYM
PARAMETER (MAXTRN = 5000)
PARAMETER (MAXSYM = 192)
INTEGER MAXLP,MAXLPH
PARAMETER (MAXLP = 2000)
PARAMETER (MAXLPH = 4000)
INTEGER NOEMAX,NOEMX2
PARAMETER (NOEMAX = 2000)
PARAMETER (NOEMX2 = 4000)
INTEGER MAXATC, MAXCB, MAXCH, MAXCI, MAXCP, MAXCT, MAXITC, MAXNBF
PARAMETER (MAXATC = 500, MAXCB = 1500, MAXCH = 3200, MAXCI = 600,
& MAXCP = 3000,MAXCT = 15500,MAXITC = 200, MAXNBF=1000)
INTEGER MAXCN
PARAMETER (MAXCN = MAXITC*(MAXITC+1)/2)
INTEGER MAXA, MAXAIM, MAXB, MAXT, MAXP
INTEGER MAXIMP, MAXNB, MAXPAD, MAXRES
INTEGER MAXSEG, MAXGRP
PARAMETER (MAXA = SIZE, MAXB = SIZE, MAXT = SIZE,
& MAXP = 2*SIZE)
PARAMETER (MAXIMP = 9200, MAXNB = 17200, MAXPAD = 8160,
& MAXRES = 14000)
PARAMETER (MAXSEG = 1000)
PARAMETER (MAXAIM = 2*SIZE)
PARAMETER (MAXGRP = 2*SIZE/3)
INTEGER REDMAX,REDMX2
PARAMETER (REDMAX = 20)
PARAMETER (REDMX2 = 80)
INTEGER MXRTRS, MXRTA, MXRTB, MXRTT, MXRTP, MXRTI, MXRTX,
& MXRTHA, MXRTHD, MXRTBL, NICM
PARAMETER (MXRTRS = 200, MXRTA = 5000, MXRTB = 5000,
& MXRTT = 5000, MXRTP = 5000, MXRTI = 2000,
& MXRTX = 5000, MXRTHA = 300, MXRTHD = 300,
& MXRTBL = 5000, NICM = 10)
INTEGER NMFTAB, NMCTAB, NMCATM, NSPLIN
PARAMETER (NMFTAB = 200, NMCTAB = 3, NMCATM = 12000, NSPLIN = 3)
INTEGER MAXSHK
PARAMETER (MAXSHK = SIZE*3/4)
INTEGER SCRMAX
PARAMETER (SCRMAX = 5000)
INTEGER MXPIGG
PARAMETER (MXPIGG=500)
INTEGER MXCOLO,MXPUMB
PARAMETER (MXCOLO=20,MXPUMB=20)
INTEGER MAXUMP, MAXEPA, MAXNUM
PARAMETER (MAXUMP = 10, MAXNUM = 4)
INTEGER MAXING
PARAMETER (MAXING=1000)
integer MAX_RINGSIZE, MAX_EACH_SIZE
parameter (MAX_RINGSIZE = 20, MAX_EACH_SIZE = 1000)
integer MAXPATHS
parameter (MAXPATHS = 8000)
integer MAX_TO_SEARCH
parameter (MAX_TO_SEARCH = 6)
REAL*8 ZERO, ONE, TWO, THREE, FOUR, FIVE, SIX,
& SEVEN, EIGHT, NINE, TEN, ELEVEN, TWELVE, THIRTN,
& FIFTN, NINETN, TWENTY, THIRTY
PARAMETER (ZERO = 0.D0, ONE = 1.D0, TWO = 2.D0,
& THREE = 3.D0, FOUR = 4.D0, FIVE = 5.D0,
& SIX = 6.D0, SEVEN = 7.D0, EIGHT = 8.D0,
& NINE = 9.D0, TEN = 10.D0, ELEVEN = 11.D0,
& TWELVE = 12.D0, THIRTN = 13.D0, FIFTN = 15.D0,
& NINETN = 19.D0, TWENTY = 20.D0, THIRTY = 30.D0)
REAL*8 FIFTY, SIXTY, SVNTY2, EIGHTY, NINETY, HUNDRD,
& ONE2TY, ONE8TY, THRHUN, THR6TY, NINE99, FIFHUN, THOSND,
& FTHSND,MEGA
PARAMETER (FIFTY = 50.D0, SIXTY = 60.D0, SVNTY2 = 72.D0,
& EIGHTY = 80.D0, NINETY = 90.D0, HUNDRD = 100.D0,
& ONE2TY = 120.D0, ONE8TY = 180.D0, THRHUN = 300.D0,
& THR6TY=360.D0, NINE99 = 999.D0, FIFHUN = 1500.D0,
& THOSND = 1000.D0,FTHSND = 5000.D0, MEGA = 1.0D6)
REAL*8 MINONE, MINTWO, MINSIX
PARAMETER (MINONE = -1.D0, MINTWO = -2.D0, MINSIX = -6.D0)
REAL*8 TENM20,TENM14,TENM8,TENM5,PT0001,PT0005,PT001,PT005,
& PT01, PT02, PT05, PTONE, PT125, PT25, SIXTH, THIRD,
& PTFOUR, PTSIX, HALF, PT75, PT9999, ONEPT5, TWOPT4
PARAMETER (TENM20 = 1.0D-20, TENM14 = 1.0D-14, TENM8 = 1.0D-8,
& TENM5 = 1.0D-5, PT0001 = 1.0D-4, PT0005 = 5.0D-4,
& PT001 = 1.0D-3, PT005 = 5.0D-3, PT01 = 0.01D0,
& PT02 = 0.02D0, PT05 = 0.05D0, PTONE = 0.1D0,
& PT125 = 0.125D0, SIXTH = ONE/SIX,PT25 = 0.25D0,
& THIRD = ONE/THREE,PTFOUR = 0.4D0, HALF = 0.5D0,
& PTSIX = 0.6D0, PT75 = 0.75D0, PT9999 = 0.9999D0,
& ONEPT5 = 1.5D0, TWOPT4 = 2.4D0)
REAL*8 ANUM,FMARK
REAL*8 RSMALL,RBIG
PARAMETER (ANUM=9999.0D0, FMARK=-999.0D0)
PARAMETER (RSMALL=1.0D-10,RBIG=1.0D20)
REAL*8 RPRECI,RBIGST
PARAMETER (RPRECI = 2.22045D-16, RBIGST = 4.49423D+307)
REAL*8 PI,RADDEG,DEGRAD,TWOPI
PARAMETER(PI=3.141592653589793D0,TWOPI=2.0D0*PI)
PARAMETER (RADDEG=180.0D0/PI)
PARAMETER (DEGRAD=PI/180.0D0)
REAL*8 COSMAX
PARAMETER (COSMAX=0.9999999999D0)
REAL*8 TIMFAC
PARAMETER (TIMFAC=4.88882129D-02)
REAL*8 KBOLTZ
PARAMETER (KBOLTZ=1.987191D-03)
REAL*8 CCELEC
PARAMETER (CCELEC=332.0716D0)
REAL*8 CNVFRQ
PARAMETER (CNVFRQ=2045.5D0/(2.99793D0*6.28319D0))
REAL*8 SPEEDL
PARAMETER (SPEEDL=2.99793D-02)
REAL*8 ATMOSP
PARAMETER (ATMOSP=1.4584007D-05)
REAL*8 PATMOS
PARAMETER (PATMOS = 1.D0 / ATMOSP )
REAL*8 BOHRR
PARAMETER (BOHRR = 0.529177249D0 )
REAL*8 TOKCAL
PARAMETER (TOKCAL = 627.5095D0 )
real*8 MDAKCAL
parameter(MDAKCAL=143.9325D0)
REAL*8 DEBYEC
PARAMETER ( DEBYEC = 2.541766D0 / BOHRR )
REAL*8 ZEROC
PARAMETER ( ZEROC = 298.15D0 )
CHARACTER*4 GTRMA, NEXTA4, CURRA4
CHARACTER*6 NEXTA6
CHARACTER*8 NEXTA8
CHARACTER*20 NEXT20
INTEGER ALLCHR, ALLSTK, ALLHP, DECODI, FIND52,
* GETATN, GETRES, GETRSN, GETSEG, GTRMI, I4VAL,
* ICHAR4, ICMP16, ILOGI4, INDX, INDXA, INDXAF,
* INDXRA, INTEG4, IREAL4, IREAL8, LOCDIF,
* LUNASS, MATOM, NEXTI, NINDX, NSELCT, NSELCTV, ATMSEL,
* PARNUM, PARINS,
* SRCHWD, SRCHWS, STRLNG, DSIZE, SSIZE
* ,GETNNB
LOGICAL CHKPTR, EQST, EQSTA, EQSTWC, EQWDWC, DOTRIM, CHECQUE,
* HYDROG, INITIA, LONE, LTSTEQ, ORDER, ORDER5,
* ORDERR, USEDDT, QTOKDEL, QDIGIT, QALPHA
REAL*8 DECODF, DOTVEC, GTRMF, LENVEC, NEXTF, RANDOM, GTRR8,
* RANUMB, R8VAL, RETVAL8, SUMVEC
* ,UMFI
EXTERNAL GTRMA, NEXTA4, CURRA4, NEXTA6, NEXTA8,NEXT20,
* ALLCHR, ALLSTK, ALLHP, DECODI, FIND52,
* GETATN, GETRES, GETRSN, GETSEG, GTRMI, I4VAL,
* ICHAR4, ICMP16, ILOGI4, INDX, INDXA, INDXAF,
* INDXRA, INTEG4, IREAL4, IREAL8, LOCDIF,
* LUNASS, MATOM, NEXTI, NINDX, NSELCT, NSELCTV, ATMSEL,
* PARNUM, PARINS,
* SRCHWD, SRCHWS, STRLNG, DSIZE, SSIZE,
* CHKPTR, EQST, EQSTA, EQSTWC, EQWDWC, DOTRIM, CHECQUE,
* HYDROG, INITIA, LONE, LTSTEQ, ORDER, ORDER5,
* ORDERR, USEDDT, QTOKDEL, QDIGIT, QALPHA,
* DECODF, DOTVEC, GTRMF, LENVEC, NEXTF, RANDOM, GTRR8,
* RANUMB, R8VAL, RETVAL8, SUMVEC
* ,UMFI
* ,GETNNB
INTEGER IMATOM
EXTERNAL IMATOM
INTEGER LEN_TRIM
EXTERNAL LEN_TRIM
CHARACTER*4 AtName
external AtName
CHARACTER*8 ElementName
external ElementName
CHARACTER*10 QNAME
external QNAME
integer IATTCH, IBORDR, CONN12, CONN13, CONN14
integer LEQUIV, LPATH
integer nbndx, nbnd2, nbnd3, NTERMA
external IATTCH, IBORDR, CONN12, CONN13, CONN14
external LEQUIV, LPATH
external nbndx, nbnd2, nbnd3, NTERMA
external find_loc
real*8 vangle, OOPNGL, TORNGL, ElementMass
external vangle, OOPNGL, TORNGL, ElementMass
INTEGER STKSIZ
PARAMETER (STKSIZ=4000000)
INTEGER LSTUSD,MAXUSD,STACK
COMMON /ISTACK/ LSTUSD,MAXUSD,STACK(STKSIZ)
INTEGER HEAPDM
PARAMETER (HEAPDM=2048000)
INTEGER FREEHP,HEAPSZ,HEAP
COMMON /HEAPST/ FREEHP,HEAPSZ,HEAP(HEAPDM)
LOGICAL LHEAP(HEAPDM)
EQUIVALENCE (LHEAP,HEAP)
INTEGER IACNB, NITCC, ICUSED, FASTER, LFAST, LMACH, OLMACH
INTEGER ICCOUNT, LOWTP, IGCNB, NITCC2
INTEGER ICCNBA, ICCNBB, ICCNBC, ICCNBD, LCCNBA, LCCNBD
COMMON /FASTI/ FASTER, LFAST, LMACH, OLMACH, NITCC, NITCC2,
& ICUSED(MAXATC), ICCOUNT(MAXATC), LOWTP(MAXATC),
& IACNB(MAXAIM), IGCNB(MAXATC),
& ICCNBA, ICCNBB, ICCNBC, ICCNBD, LCCNBA, LCCNBD
REAL*8 DX,DY,DZ
COMMON /DERIVR/ DX(MAXAIM),DY(MAXAIM),DZ(MAXAIM)
INTEGER LENENP, LENENT, LENENV, LENENA
PARAMETER (LENENP = 50, LENENT = 70, LENENV = 50,
& LENENA = LENENP + LENENT + LENENV )
INTEGER TOTE, TOTKE, EPOT, TEMPS, GRMS, BPRESS, PJNK1, PJNK2,
& PJNK3, PJNK4, HFCTE, HFCKE, EHFC, EWORK, VOLUME, PRESSE,
& PRESSI, VIRI, VIRE, VIRKE, TEPR, PEPR, KEPR, KEPR2,
& DROFFA,
& XTLTE, XTLKE, XTLPE, XTLTEM, XTLPEP, XTLKEP, XTLKP2,
& TOT4, TOTK4, EPOT4, TEM4, MbMom, BodyT, PartT
& , SELF, SCREEN, COUL ,SOLV, INTER
& ,FQKIN
PARAMETER (TOTE = 1, TOTKE = 2, EPOT = 3, TEMPS = 4,
& GRMS = 5, BPRESS = 6, PJNK1 = 7, PJNK2 = 8,
& PJNK3 = 9, PJNK4 = 10, HFCTE = 11, HFCKE = 12,
& EHFC = 13, EWORK = 11, VOLUME = 15, PRESSE = 16,
& PRESSI = 17, VIRI = 18, VIRE = 19, VIRKE = 20,
& TEPR = 21, PEPR = 22, KEPR = 23, KEPR2 = 24,
& DROFFA = 26, XTLTE = 27, XTLKE = 28,
& XTLPE = 29, XTLTEM = 30, XTLPEP = 31, XTLKEP = 32,
& XTLKP2 = 33,
& TOT4 = 37, TOTK4 = 38, EPOT4 = 39, TEM4 = 40,
& MbMom = 41, BodyT = 42, PartT = 43
& , SELF = 45, SCREEN = 46, COUL = 47,
& SOLV = 48, INTER = 49
& ,FQKIN = 50
& )
INTEGER BOND, ANGLE, UREYB, DIHE, IMDIHE, VDW, ELEC, HBOND,
& USER, CHARM, CDIHE, CINTCR, CQRT, NOE, SBNDRY,
& IMVDW, IMELEC, IMHBND, EWKSUM, EWSELF, EXTNDE, RXNFLD,
& ST2, IMST2, TSM, QMEL, QMVDW, ASP, EHARM, GEO, MDIP,
& PRMS, PANG, SSBP, BK4D, SHEL, RESD, SHAP,
& STRB, OOPL, PULL, POLAR, DMC, RGY, EWEXCL, EWQCOR,
& EWUTIL, PBELEC, PBNP, PINT, MbDefrm, MbElec, STRSTR,
& BNDBND, BNDTW, EBST, MBST, BBT, SST, GBEnr, GSBP
& , HMCM
& , ADUMB
& , HYDR
& , FQPOL
PARAMETER (BOND = 1, ANGLE = 2, UREYB = 3, DIHE = 4,
& IMDIHE = 5, VDW = 6, ELEC = 7, HBOND = 8,
& USER = 9, CHARM = 10, CDIHE = 11, CINTCR = 12,
& CQRT = 13, NOE = 14, SBNDRY = 15, IMVDW = 16,
& IMELEC = 17, IMHBND = 18, EWKSUM = 19, EWSELF = 20,
& EXTNDE = 21, RXNFLD = 22, ST2 = 23, IMST2 = 24,
& TSM = 25, QMEL = 26, QMVDW = 27, ASP = 28,
& EHARM = 29, GEO = 30, MDIP = 31, PINT = 32,
& PRMS = 33, PANG = 34, SSBP = 35, BK4D = 36,
& SHEL = 37, RESD = 38, SHAP = 39, STRB = 40,
& OOPL = 41, PULL = 42, POLAR = 43, DMC = 44,
& RGY = 45, EWEXCL = 46, EWQCOR = 47, EWUTIL = 48,
& PBELEC = 49, PBNP = 50, MbDefrm= 51, MbElec = 52,
& STRSTR = 53, BNDBND = 54, BNDTW = 55, EBST = 56,
& MBST = 57, BBT = 58, SST = 59, GBEnr = 60,
& GSBP = 65
& , HMCM = 61
& , ADUMB = 62
& , HYDR = 63
& , FQPOL = 65
& )
INTEGER VEXX, VEXY, VEXZ, VEYX, VEYY, VEYZ, VEZX, VEZY, VEZZ,
& VIXX, VIXY, VIXZ, VIYX, VIYY, VIYZ, VIZX, VIZY, VIZZ,
& PEXX, PEXY, PEXZ, PEYX, PEYY, PEYZ, PEZX, PEZY, PEZZ,
& PIXX, PIXY, PIXZ, PIYX, PIYY, PIYZ, PIZX, PIZY, PIZZ
PARAMETER ( VEXX = 1, VEXY = 2, VEXZ = 3, VEYX = 4,
& VEYY = 5, VEYZ = 6, VEZX = 7, VEZY = 8,
& VEZZ = 9,
& VIXX = 10, VIXY = 11, VIXZ = 12, VIYX = 13,
& VIYY = 14, VIYZ = 15, VIZX = 16, VIZY = 17,
& VIZZ = 18,
& PEXX = 19, PEXY = 20, PEXZ = 21, PEYX = 22,
& PEYY = 23, PEYZ = 24, PEZX = 25, PEZY = 26,
& PEZZ = 27,
& PIXX = 28, PIXY = 29, PIXZ = 30, PIYX = 31,
& PIYY = 32, PIYZ = 33, PIZX = 34, PIZY = 35,
& PIZZ = 36)
CHARACTER*4 CEPROP, CETERM, CEPRSS
COMMON /ANER/ CEPROP(LENENP), CETERM(LENENT), CEPRSS(LENENV)
LOGICAL QEPROP, QETERM, QEPRSS
COMMON /QENER/ QEPROP(LENENP), QETERM(LENENT), QEPRSS(LENENV)
REAL*8 EPROP, ETERM, EPRESS
COMMON /ENER/ EPROP(LENENP), ETERM(LENENT), EPRESS(LENENV)
REAL*8 EPRPA, EPRP2A, EPRPP, EPRP2P,
& ETRMA, ETRM2A, ETRMP, ETRM2P,
& EPRSA, EPRS2A, EPRSP, EPRS2P
COMMON /ENACCM/ EPRPA(LENENP), ETRMA(LENENT), EPRSA(LENENV),
& EPRP2A(LENENP),ETRM2A(LENENT),EPRS2A(LENENV),
& EPRPP(LENENP), ETRMP(LENENT), EPRSP(LENENV),
& EPRP2P(LENENP),ETRM2P(LENENT),EPRS2P(LENENV)
INTEGER ECALLS, TOT1ST, TOT2ND
COMMON /EMISCI/ ECALLS, TOT1ST, TOT2ND
REAL*8 EOLD, FITA, DRIFTA, EAT0A, CORRA, FITP, DRIFTP,
& EAT0P, CORRP
COMMON /EMISCR/ EOLD, FITA, DRIFTA, EAT0A, CORRA,
& FITP, DRIFTP, EAT0P, CORRP
REAL*8 TSMTRM(LENENT),TSMTMP(LENENT)
COMMON /TSMENG/ TSMTRM,TSMTMP
REAL*8 EHQBM
LOGICAL HQBM
COMMON /HQBMVAR/HQBM
INTEGER NPARMX,MNBCMP,LENDSK
PARAMETER (NPARMX=1000,MNBCMP=300,LENDSK=200000)
INTEGER IJXXCM,IJXYCM,IJXZCM,IJYXCM,IJYYCM
INTEGER IJYZCM,IJZXCM,IJZYCM,IJZZCM
INTEGER IIXXCM,IIXYCM,IIXZCM,IIYYCM
INTEGER IIYZCM,IIZZCM
INTEGER JJXXCM,JJXYCM,JJXZCM,JJYYCM
INTEGER JJYZCM,JJZZCM
PARAMETER (IJXXCM=1,IJXYCM=2,IJXZCM=3,IJYXCM=4,IJYYCM=5)
PARAMETER (IJYZCM=6,IJZXCM=7,IJZYCM=8,IJZZCM=9)
PARAMETER (IIXXCM=1,IIXYCM=2,IIXZCM=3,IIYYCM=4)
PARAMETER (IIYZCM=5,IIZZCM=6)
PARAMETER (JJXXCM=1,JJXYCM=2,JJXZCM=3,JJYYCM=4)
PARAMETER (JJYZCM=5,JJZZCM=6)
INTEGER ITER,IPAR1,IPAR2,NFSAV,PINBCM,PJNBCM,PDD1CM,LENCMP
LOGICAL QDISK,QDW,QCMPCT
COMMON /DIMBI/ ITER,IPAR1,IPAR2,NFSAV,PINBCM,PJNBCM,LENCMP
COMMON /DIMBL/ QDISK,QDW,QCMPCT
INTEGER MAXTIT
PARAMETER (MAXTIT=32)
INTEGER NTITLA,NTITLB
CHARACTER*80 TITLEA,TITLEB
COMMON /NTITLA/ NTITLA,NTITLB
COMMON /CTITLA/ TITLEA(MAXTIT),TITLEB(MAXTIT)
INTEGER NAT3,NADD,NPAR,NFREG,NFRET,BLATOM
INTEGER ATMPAR(2,*),ATMPAS(2,*),ATMPAD(2,*)
INTEGER BNBND(*),BIMAG(*)
INTEGER INBCMP(*),JNBCMP(*),PARDIM
INTEGER ITMX,IUNMOD,IUNRMD,SAVF
INTEGER NBOND,IB(*),JB(*)
REAL*8 X(*),Y(*),Z(*),AMASS(*),DDSCR(*)
REAL*8 DDV(NAT3,*),PARDDV(PARDIM,*),DDM(*),DDS(*)
REAL*8 DDF(*),PARDDF(*),DDEV(*),PARDDE(*)
REAL*8 DD1BLK(*),DD1BLL(*),DD1CMP(*)
REAL*8 TOLDIM,DDVALM
REAL*8 PARFRQ,CUTF1
LOGICAL LNOMA,LRAISE,LSCI,LBIG
INTEGER NATOM,NATP,NDIM,I,J,II,OLDFAS,OLDPRN,IUPD
INTEGER NPARC,NPARD,NPARS,NFCUT1,NFREG2,NFREG6
INTEGER IH1,IH2,IH3,IH4,IH5,IH6,IH7,IH8
INTEGER IS1,IS2,IS3,IS4,JSPACE,JSP,DDSS,DD5
INTEGER ISTRT,ISTOP,IPA1,IPA2,IRESF
INTEGER ATMPAF,INIDS,TRAROT
INTEGER SUBLIS,ATMCOR
INTEGER NFRRES,DDVBAS
INTEGER DDV2,DDVAL
INTEGER LENCM,NTR,NFRE,NFC,N1,N2,NFCUT,NSUBP
INTEGER SCIFV1,SCIFV2,SCIFV3,SCIFV4,SCIFV6
INTEGER DRATQ,ERATQ,E2RATQ,BDRATQ,INRATQ
INTEGER I620,I640,I660,I700,I720,I760,I800,I840,I880,I920
REAL*8 CVGMX,TOLER
LOGICAL LCARD,LAPPE,LPURG,LWDINI,QCALC,QMASWT,QMIX,QDIAG
QCALC=.TRUE.
LWDINI=.FALSE.
INIDS=0
IS3=0
IS4=0
LPURG=.TRUE.
ITER=0
NADD=0
NFSAV=0
TOLER=TENM5
QDIAG=.TRUE.
CVGMX=HUNDRD
QMIX=.FALSE.
NATOM=NAT3/3
NFREG6=(NFREG-6)/NPAR
NFREG2=NFREG/2
NFRRES=(NFREG+6)/2
IF(NFREG.GT.PARDIM) CALL WRNDIE(-3,'<NMDIMB>',
1 'NFREG IS LARGER THAN PARDIM*3')
ASSIGN 801 TO I800 ! { dg-warning "Obsolete: ASSIGN" "Obsolete: ASSIGN" }
GOTO 800
801 CONTINUE
ASSIGN 721 TO I720 ! { dg-warning "Obsolete: ASSIGN" "Obsolete: ASSIGN" }
GOTO 720
721 CONTINUE
ASSIGN 761 TO I760 ! { dg-warning "Obsolete: ASSIGN" "Obsolete: ASSIGN" }
GOTO 760
761 CONTINUE
ASSIGN 921 TO I920 ! { dg-warning "Obsolete: ASSIGN" "Obsolete: ASSIGN" }
GOTO 920
921 CONTINUE
IF(LSCI) THEN
ASSIGN 841 TO I840 ! { dg-warning "Obsolete: ASSIGN" "Obsolete: ASSIGN" }
GOTO 840
841 CONTINUE
ELSE
ASSIGN 881 TO I880 ! { dg-warning "Obsolete: ASSIGN" "Obsolete: ASSIGN" }
GOTO 880
881 CONTINUE
ENDIF
QMASWT=(.NOT.LNOMA)
IF(.NOT. QDISK) THEN
LENCM=INBCMP(NATOM-1)*9+NATOM*6
DO I=1,LENCM
DD1CMP(I)=0.0
ENDDO
OLDFAS=LFAST
QCMPCT=.TRUE.
LFAST = -1
CALL ENERGY(X,Y,Z,DX,DY,DZ,BNBND,BIMAG,NAT3,DD1CMP,.TRUE.,1)
LFAST=OLDFAS
QCMPCT=.FALSE.
CALL MASSDD(DD1CMP,DDM,INBCMP,JNBCMP,NATOM)
ELSE
CALL WRNDIE(-3,'<NMDIMB>','QDISK OPTION NOT SUPPORTED YET')
ENDIF
CALL TRROT(X,Y,Z,DDV,NAT3,1,DDM)
CALL CPARAY(HEAP(TRAROT),DDV,NAT3,1,6,1)
NTR=6
OLDPRN=PRNLEV
PRNLEV=1
CALL ORTHNM(1,6,NTR,HEAP(TRAROT),NAT3,.FALSE.,TOLER)
PRNLEV=OLDPRN
IF(IUNRMD .LT. 0) THEN
IF(PRNLEV.GE.2) WRITE(OUTU,502) NPAR
502 FORMAT(/' NMDIMB: Calculating initial basis from block ',
1 'diagonals'/' NMDIMB: The number of blocks is ',I5/)
NFRET = 6
DO I=1,NPAR
IS1=ATMPAR(1,I)
IS2=ATMPAR(2,I)
NDIM=(IS2-IS1+1)*3
NFRE=NDIM
IF(NFRE.GT.NFREG6) NFRE=NFREG6
IF(NFREG6.EQ.0) NFRE=1
CALL FILUPT(HEAP(IUPD),NDIM)
CALL MAKDDU(DD1BLK,DD1CMP,INBCMP,JNBCMP,HEAP(IUPD),
1 IS1,IS2,NATOM)
IF(PRNLEV.GE.9) CALL PRINTE(OUTU,EPROP,ETERM,'VIBR',
1 'ENR',.TRUE.,1,ZERO,ZERO)
IH1=1
NATP=NDIM+1
IH2=IH1+NATP
IH3=IH2+NATP
IH4=IH3+NATP
IH5=IH4+NATP
IH6=IH5+NATP
IH7=IH6+NATP
IH8=IH7+NATP
CALL DIAGQ(NDIM,NFRE,DD1BLK,PARDDV,DDS(IH2),DDS(IH3),
1 DDS(IH4),DDS(IH5),DDS,DDS(IH6),DDS(IH7),DDS(IH8),NADD)
CALL ADJNME(DDV,PARDDV,NAT3,NDIM,NFRE,NFRET,IS1,IS2)
IF(LSCI) THEN
DO J=1,NFRE
PARDDF(J)=CNVFRQ*SQRT(ABS(PARDDE(J)))
IF(PARDDE(J) .LT. 0.0) PARDDF(J)=-PARDDF(J)
ENDDO
ELSE
DO J=1,NFRE
PARDDE(J)=DDS(J)
PARDDF(J)=CNVFRQ*SQRT(ABS(PARDDE(J)))
IF(PARDDE(J) .LT. 0.0) PARDDF(J)=-PARDDF(J)
ENDDO
ENDIF
IF(PRNLEV.GE.2) THEN
WRITE(OUTU,512) I
WRITE(OUTU,514)
WRITE(OUTU,516) (J,PARDDF(J),J=1,NFRE)
ENDIF
NFRET=NFRET+NFRE
IF(NFRET .GE. NFREG) GOTO 10
ENDDO
512 FORMAT(/' NMDIMB: Diagonalization of part',I5,' completed')
514 FORMAT(' NMDIMB: Frequencies'/)
516 FORMAT(5(I4,F12.6))
10 CONTINUE
OLDPRN=PRNLEV
PRNLEV=1
CALL ORTHNM(1,NFRET,NFRET,DDV,NAT3,LPURG,TOLER)
PRNLEV=OLDPRN
IF(PRNLEV.GE.2) THEN
WRITE(OUTU,521) ITER
WRITE(OUTU,523) NFRET
ENDIF
521 FORMAT(/' NMDIMB: Iteration number = ',I5)
523 FORMAT(' NMDIMB: Dimension of the reduced basis set = ',I5)
IF(LBIG) THEN
IF(PRNLEV.GE.2) WRITE(OUTU,585) NFRET,IUNMOD
525 FORMAT(' NMDIMB: ',I5,' basis vectors are saved in unit',I5)
REWIND (UNIT=IUNMOD)
LCARD=.FALSE.
CALL WRTNMD(LCARD,1,NFRET,NAT3,DDV,DDSCR,DDEV,IUNMOD,AMASS)
CALL SAVEIT(IUNMOD)
ELSE
CALL CPARAY(HEAP(DDVBAS),DDV,NAT3,1,NFRET,1)
ENDIF
CALL RBDG(X,Y,Z,NAT3,NDIM,NFRET,DDV,DDF,DDEV,
1 DDSCR,HEAP(DD5),HEAP(DDSS),HEAP(DDV2),NADD,
2 INBCMP,JNBCMP,HEAP(DDVBAS),DD1CMP,QMIX,0,0,IS3,IS4,
3 CUTF1,NFCUT1,NFREG,HEAP(IUPD),DD1BLL,HEAP(SCIFV1),
4 HEAP(SCIFV2),HEAP(SCIFV3),HEAP(SCIFV4),HEAP(SCIFV6),
5 HEAP(DRATQ),HEAP(ERATQ),HEAP(E2RATQ),
6 HEAP(BDRATQ),HEAP(INRATQ),LSCI,LBIG,IUNMOD)
ASSIGN 621 TO I620 ! { dg-warning "Obsolete: ASSIGN" "Obsolete: ASSIGN" }
GOTO 620
621 CONTINUE
ASSIGN 701 TO I700 ! { dg-warning "Obsolete: ASSIGN" "Obsolete: ASSIGN" }
GOTO 700
701 CONTINUE
IF(ITER.EQ.ITMX) THEN
CALL CLEANHP(NAT3,NFREG,NPARD,NSUBP,PARDIM,DDV2,DDSS,DDVBAS,
1 DDVAL,JSPACE,TRAROT,
2 SCIFV1,SCIFV2,SCIFV3,SCIFV4,SCIFV6,
3 DRATQ,ERATQ,E2RATQ,BDRATQ,INRATQ,IUPD,ATMPAF,
4 ATMCOR,SUBLIS,LSCI,QDW,LBIG)
RETURN
ENDIF
ELSE
IF(PRNLEV.GE.2) THEN
WRITE(OUTU,531)
531 FORMAT(/' NMDIMB: Calculations restarted')
ENDIF
ISTRT=1
ISTOP=99999999
LCARD=.FALSE.
LAPPE=.FALSE.
CALL RDNMD(LCARD,NFRET,NFREG,NAT3,NDIM,
1 DDV,DDSCR,DDF,DDEV,
2 IUNRMD,LAPPE,ISTRT,ISTOP)
NFRET=NDIM
IF(NFRET.GT.NFREG) THEN
NFRET=NFREG
CALL WRNDIE(-1,'<NMDIMB>',
1 'Not enough space to hold the basis. Increase NMODes')
ENDIF
IF(PRNLEV.GE.2) THEN
WRITE(OUTU,533) NFRET,IUNRMD
WRITE(OUTU,514)
WRITE(OUTU,516) (J,DDF(J),J=1,NFRET)
ENDIF
533 FORMAT(/' NMDIMB: ',I5,' restart modes read from unit ',I5)
NFRRES=NFRET
ENDIF
CALL SELNMD(DDF,NFRET,CUTF1,NFCUT1)
IF(IUNRMD.LT.0) THEN
IF(NFCUT1*2-6.GT.NFREG) THEN
IF(PRNLEV.GE.2) WRITE(OUTU,537) DDF(NFRRES)
NFCUT1=NFRRES
CUTF1=DDF(NFRRES)
ENDIF
ELSE
CUTF1=DDF(NFRRES)
ENDIF
537 FORMAT(/' NMDIMB: Too many vectors for the given cutoff frequency'
1 /' Cutoff frequency is decreased to',F9.3)
CALL PARTIC(NAT3,NFREG,NFCUT1,NPARMX,NPARC,ATMPAR,NFRRES,
1 PARDIM)
NPARS=NPARC
DO I=1,NPARC
ATMPAS(1,I)=ATMPAR(1,I)
ATMPAS(2,I)=ATMPAR(2,I)
ENDDO
IF(QDW) THEN
IF(IPAR1.EQ.0.OR.IPAR2.EQ.0) LWDINI=.TRUE.
IF(IPAR1.GE.IPAR2) LWDINI=.TRUE.
IF(IABS(IPAR1).GT.NPARC*2) LWDINI=.TRUE.
IF(IABS(IPAR2).GT.NPARC*2) LWDINI=.TRUE.
IF(ITER.EQ.0) LWDINI=.TRUE.
ENDIF
ITMX=ITMX+ITER
IF(PRNLEV.GE.2) THEN
WRITE(OUTU,543) ITER,ITMX
IF(QDW) WRITE(OUTU,545) IPAR1,IPAR2
ENDIF
543 FORMAT(/' NMDIMB: Previous iteration number = ',I8/
1 ' NMDIMB: Iteration number to reach = ',I8)
545 FORMAT(' NMDIMB: Previous sub-blocks = ',I5,2X,I5)
IF(SAVF.LE.0) SAVF=NPARC
IF(PRNLEV.GE.2) WRITE(OUTU,547) SAVF
547 FORMAT(' NMDIMB: Eigenvectors will be saved every',I5,
1 ' iterations')
IF(QDW) THEN
NSUBP=1
CALL PARTID(NPARC,ATMPAR,NPARD,ATMPAD,NPARMX)
ATMPAF=ALLHP(INTEG4(NPARD*NPARD))
ATMCOR=ALLHP(INTEG4(NATOM))
DDVAL=ALLHP(IREAL8(NPARD*NPARD))
CALL CORARR(ATMPAD,NPARD,HEAP(ATMCOR),NATOM)
CALL PARLIS(HEAP(ATMCOR),HEAP(ATMPAF),INBCMP,JNBCMP,NPARD,
2 NSUBP,NATOM,X,Y,Z,NBOND,IB,JB,DD1CMP,HEAP(DDVAL),DDVALM)
SUBLIS=ALLHP(INTEG4(NSUBP*2))
CALL PARINT(HEAP(ATMPAF),NPARD,HEAP(SUBLIS),NSUBP)
CALL INIPAF(HEAP(ATMPAF),NPARD)
IPA1=IPAR1
IPA2=IPAR2
IRESF=0
IF(LWDINI) THEN
ITER=0
LWDINI=.FALSE.
GOTO 500
ENDIF
DO II=1,NSUBP
CALL IPART(HEAP(SUBLIS),II,IPAR1,IPAR2,HEAP(ATMPAF),
1 NPARD,QCALC)
IF((IPAR1.EQ.IPA1).AND.(IPAR2.EQ.IPA2)) GOTO 500
ENDDO
ENDIF
500 CONTINUE
DO WHILE((CVGMX.GT.TOLDIM).AND.(ITER.LT.ITMX))
IF(.NOT.QDW) THEN
ITER=ITER+1
IF(PRNLEV.GE.2) WRITE(OUTU,553) ITER
553 FORMAT(/' NMDIMB: Iteration number = ',I8)
IF(INIDS.EQ.0) THEN
INIDS=1
ELSE
INIDS=0
ENDIF
CALL PARTDS(NAT3,NPARC,ATMPAR,NPARS,ATMPAS,INIDS,NPARMX,
1 DDF,NFREG,CUTF1,PARDIM,NFCUT1)
ASSIGN 641 to I640 ! { dg-warning "Obsolete: ASSIGN" "Obsolete: ASSIGN" }
GOTO 640
641 CONTINUE
QDIAG=.FALSE.
ASSIGN 622 TO I620 ! { dg-warning "Obsolete: ASSIGN" "Obsolete: ASSIGN" }
GOTO 620
622 CONTINUE
QDIAG=.TRUE.
ASSIGN 702 TO I700 ! { dg-warning "Obsolete: ASSIGN" "Obsolete: ASSIGN" }
GOTO 700
702 CONTINUE
ELSE
DO II=1,NSUBP
CALL IPART(HEAP(SUBLIS),II,IPAR1,IPAR2,HEAP(ATMPAF),
1 NPARD,QCALC)
IF(QCALC) THEN
IRESF=IRESF+1
ITER=ITER+1
IF(PRNLEV.GE.2) WRITE(OUTU,553) ITER
ASSIGN 661 TO I660 ! { dg-warning "Obsolete: ASSIGN" "Obsolete: ASSIGN" }
GOTO 660
661 CONTINUE
ENDIF
IF((IRESF.EQ.SAVF).OR.(ITER.EQ.ITMX)) THEN
IRESF=0
QDIAG=.FALSE.
ASSIGN 623 TO I620 ! { dg-warning "Obsolete: ASSIGN" "Obsolete: ASSIGN" }
GOTO 620
623 CONTINUE
QDIAG=.TRUE.
IF((CVGMX.LE.TOLDIM).OR.(ITER.EQ.ITMX)) GOTO 600
ASSIGN 703 TO I700 ! { dg-warning "Obsolete: ASSIGN" "Obsolete: ASSIGN" }
GOTO 700
703 CONTINUE
ENDIF
ENDDO
ENDIF
ENDDO
600 CONTINUE
ASSIGN 704 TO I700 ! { dg-warning "Obsolete: ASSIGN" "Obsolete: ASSIGN" }
GOTO 700
704 CONTINUE
CALL CLEANHP(NAT3,NFREG,NPARD,NSUBP,PARDIM,DDV2,DDSS,DDVBAS,
1 DDVAL,JSPACE,TRAROT,
2 SCIFV1,SCIFV2,SCIFV3,SCIFV4,SCIFV6,
3 DRATQ,ERATQ,E2RATQ,BDRATQ,INRATQ,IUPD,ATMPAF,
4 ATMCOR,SUBLIS,LSCI,QDW,LBIG)
RETURN
620 CONTINUE
IF(IUNRMD.LT.0) THEN
CALL SELNMD(DDF,NFRET,CUTF1,NFC)
N1=NFCUT1
N2=(NFRET+6)/2
NFCUT=MAX(N1,N2)
IF(NFCUT*2-6 .GT. NFREG) THEN
NFCUT=(NFREG+6)/2
CUTF1=DDF(NFCUT)
IF(PRNLEV.GE.2) THEN
WRITE(OUTU,562) ITER
WRITE(OUTU,564) CUTF1
ENDIF
ENDIF
ELSE
NFCUT=NFRET
NFC=NFRET
ENDIF
562 FORMAT(/' NMDIMB: Not enough space to hold the residual vectors'/
1 ' into DDV array during iteration ',I5)
564 FORMAT(' Cutoff frequency is changed to ',F9.3)
ISTRT=1
ISTOP=NFCUT
CALL CLETR(DDV,HEAP(TRAROT),NAT3,ISTRT,ISTOP,NFCUT,DDEV,DDF)
CALL RNMTST(DDV,HEAP(DDVBAS),NAT3,DDSCR,DD1CMP,INBCMP,JNBCMP,
2 7,NFCUT,CVGMX,NFCUT,NFC,QDIAG,LBIG,IUNMOD)
NFSAV=NFCUT
IF(QDIAG) THEN
NFRET=NFCUT*2-6
IF(PRNLEV.GE.2) WRITE(OUTU,566) NFRET
566 FORMAT(/' NMDIMB: Diagonalization with residual vectors. '/
1 ' Dimension of the reduced basis set'/
2 ' before orthonormalization = ',I5)
NFCUT=NFRET
OLDPRN=PRNLEV
PRNLEV=1
CALL ORTHNM(1,NFRET,NFCUT,DDV,NAT3,LPURG,TOLER)
PRNLEV=OLDPRN
NFRET=NFCUT
IF(PRNLEV.GE.2) WRITE(OUTU,568) NFRET
568 FORMAT(' after orthonormalization = ',I5)
IF(LBIG) THEN
IF(PRNLEV.GE.2) WRITE(OUTU,570) NFCUT,IUNMOD
570 FORMAT(' NMDIMB: ',I5,' basis vectors are saved in unit',I5)
REWIND (UNIT=IUNMOD)
LCARD=.FALSE.
CALL WRTNMD(LCARD,1,NFCUT,NAT3,DDV,DDSCR,DDEV,IUNMOD,AMASS)
CALL SAVEIT(IUNMOD)
ELSE
CALL CPARAY(HEAP(DDVBAS),DDV,NAT3,1,NFCUT,1)
ENDIF
QMIX=.FALSE.
CALL RBDG(X,Y,Z,NAT3,NDIM,NFRET,DDV,DDF,DDEV,
1 DDSCR,HEAP(DD5),HEAP(DDSS),HEAP(DDV2),NADD,
2 INBCMP,JNBCMP,HEAP(DDVBAS),DD1CMP,QMIX,0,0,IS3,IS4,
3 CUTF1,NFCUT1,NFREG,HEAP(IUPD),DD1BLL,HEAP(SCIFV1),
4 HEAP(SCIFV2),HEAP(SCIFV3),HEAP(SCIFV4),HEAP(SCIFV6),
5 HEAP(DRATQ),HEAP(ERATQ),HEAP(E2RATQ),
6 HEAP(BDRATQ),HEAP(INRATQ),LSCI,LBIG,IUNMOD)
CALL SELNMD(DDF,NFRET,CUTF1,NFCUT1)
ENDIF
GOTO I620 ! { dg-warning "Obsolete: Assigned" "Assigned GO TO" }
640 CONTINUE
DO I=1,NPARC
NFCUT1=NFRRES
IS1=ATMPAR(1,I)
IS2=ATMPAR(2,I)
NDIM=(IS2-IS1+1)*3
IF(PRNLEV.GE.2) WRITE(OUTU,573) I,IS1,IS2
573 FORMAT(/' NMDIMB: Mixed diagonalization, part ',I5/
1 ' NMDIMB: Block limits: ',I5,2X,I5)
IF(NDIM+NFCUT1.GT.PARDIM) CALL WRNDIE(-3,'<NMDIMB>',
1 'Error in dimension of block')
NFRET=NFCUT1
IF(NFRET.GT.NFREG) NFRET=NFREG
CALL CLETR(DDV,HEAP(TRAROT),NAT3,1,NFCUT1,NFCUT,DDEV,DDF)
NFCUT1=NFCUT
CALL ADZER(DDV,1,NFCUT1,NAT3,IS1,IS2)
NFSAV=NFCUT1
OLDPRN=PRNLEV
PRNLEV=1
CALL ORTHNM(1,NFCUT1,NFCUT,DDV,NAT3,LPURG,TOLER)
PRNLEV=OLDPRN
CALL CPARAY(HEAP(DDVBAS),DDV,NAT3,1,NFCUT,1)
NFRET=NDIM+NFCUT
QMIX=.TRUE.
CALL RBDG(X,Y,Z,NAT3,NDIM,NFRET,DDV,DDF,DDEV,
1 DDSCR,HEAP(DD5),HEAP(DDSS),HEAP(DDV2),NADD,
2 INBCMP,JNBCMP,HEAP(DDVBAS),DD1CMP,QMIX,IS1,IS2,IS3,IS4,
3 CUTF1,NFCUT,NFREG,HEAP(IUPD),DD1BLL,HEAP(SCIFV1),
4 HEAP(SCIFV2),HEAP(SCIFV3),HEAP(SCIFV4),HEAP(SCIFV6),
5 HEAP(DRATQ),HEAP(ERATQ),HEAP(E2RATQ),
6 HEAP(BDRATQ),HEAP(INRATQ),LSCI,LBIG,IUNMOD)
QMIX=.FALSE.
IF(NFCUT.GT.NFRRES) NFCUT=NFRRES
NFCUT1=NFCUT
NFRET=NFCUT
ENDDO
GOTO I640 ! { dg-warning "Obsolete: Assigned" "Assigned GO TO" }
660 CONTINUE
NFCUT1=NFRRES
IS1=ATMPAD(1,IPAR1)
IS2=ATMPAD(2,IPAR1)
IS3=ATMPAD(1,IPAR2)
IS4=ATMPAD(2,IPAR2)
NDIM=(IS2-IS1+IS4-IS3+2)*3
IF(PRNLEV.GE.2) WRITE(OUTU,577) IPAR1,IPAR2,IS1,IS2,IS3,IS4
577 FORMAT(/' NMDIMB: Mixed double window diagonalization, parts ',
1 2I5/
2 ' NMDIMB: Block limits: ',I5,2X,I5,4X,I5,2X,I5)
IF(NDIM+NFCUT1.GT.PARDIM) CALL WRNDIE(-3,'<NMDIMB>',
1 'Error in dimension of block')
NFRET=NFCUT1
IF(NFRET.GT.NFREG) NFRET=NFREG
CALL CLETR(DDV,HEAP(TRAROT),NAT3,1,NFCUT1,NFCUT,DDEV,DDF)
NFCUT1=NFCUT
NFSAV=NFCUT1
CALL ADZERD(DDV,1,NFCUT1,NAT3,IS1,IS2,IS3,IS4)
OLDPRN=PRNLEV
PRNLEV=1
CALL ORTHNM(1,NFCUT1,NFCUT,DDV,NAT3,LPURG,TOLER)
PRNLEV=OLDPRN
CALL CPARAY(HEAP(DDVBAS),DDV,NAT3,1,NFCUT,1)
NFRET=NDIM+NFCUT
QMIX=.TRUE.
CALL RBDG(X,Y,Z,NAT3,NDIM,NFRET,DDV,DDF,DDEV,
1 DDSCR,HEAP(DD5),HEAP(DDSS),HEAP(DDV2),NADD,
2 INBCMP,JNBCMP,HEAP(DDVBAS),DD1CMP,QMIX,IS1,IS2,IS3,IS4,
3 CUTF1,NFCUT,NFREG,HEAP(IUPD),DD1BLL,HEAP(SCIFV1),
4 HEAP(SCIFV2),HEAP(SCIFV3),HEAP(SCIFV4),HEAP(SCIFV6),
5 HEAP(DRATQ),HEAP(ERATQ),HEAP(E2RATQ),
6 HEAP(BDRATQ),HEAP(INRATQ),LSCI,LBIG,IUNMOD)
QMIX=.FALSE.
IF(NFCUT.GT.NFRRES) NFCUT=NFRRES
NFCUT1=NFCUT
NFRET=NFCUT
GOTO I660 ! { dg-warning "Obsolete: Assigned" "Assigned GO TO" }
700 CONTINUE
IF(PRNLEV.GE.2) WRITE(OUTU,583) IUNMOD
583 FORMAT(/' NMDIMB: Saving the eigenvalues and eigenvectors to unit'
1 ,I4)
REWIND (UNIT=IUNMOD)
ISTRT=1
ISTOP=NFSAV
LCARD=.FALSE.
IF(PRNLEV.GE.2) WRITE(OUTU,585) NFSAV,IUNMOD
585 FORMAT(' NMDIMB: ',I5,' modes are saved in unit',I5)
CALL WRTNMD(LCARD,ISTRT,ISTOP,NAT3,DDV,DDSCR,DDEV,IUNMOD,
1 AMASS)
CALL SAVEIT(IUNMOD)
GOTO I700 ! { dg-warning "Obsolete: Assigned" "Assigned GO TO" }
720 CONTINUE
DDV2=ALLHP(IREAL8((PARDIM+3)*(PARDIM+3)))
JSPACE=IREAL8((PARDIM+4))*8
JSP=IREAL8(((PARDIM+3)*(PARDIM+4))/2)
JSPACE=JSPACE+JSP
DDSS=ALLHP(JSPACE)
DD5=DDSS+JSPACE-JSP
GOTO I720 ! { dg-warning "Obsolete: Assigned" "Assigned GO TO" }
760 CONTINUE
IF(LBIG) THEN
DDVBAS=ALLHP(IREAL8(NAT3))
ELSE
DDVBAS=ALLHP(IREAL8(NFREG*NAT3))
ENDIF
GOTO I760 ! { dg-warning "Obsolete: Assigned" "Assigned GO TO" }
800 CONTINUE
TRAROT=ALLHP(IREAL8(6*NAT3))
GOTO I800 ! { dg-warning "Obsolete: Assigned" "Assigned GO TO" }
840 CONTINUE
SCIFV1=ALLHP(IREAL8(PARDIM+3))
SCIFV2=ALLHP(IREAL8(PARDIM+3))
SCIFV3=ALLHP(IREAL8(PARDIM+3))
SCIFV4=ALLHP(IREAL8(PARDIM+3))
SCIFV6=ALLHP(IREAL8(PARDIM+3))
DRATQ=ALLHP(IREAL8(PARDIM+3))
ERATQ=ALLHP(IREAL8(PARDIM+3))
E2RATQ=ALLHP(IREAL8(PARDIM+3))
BDRATQ=ALLHP(IREAL8(PARDIM+3))
INRATQ=ALLHP(INTEG4(PARDIM+3))
GOTO I840 ! { dg-warning "Obsolete: Assigned" "Assigned GO TO" }
880 CONTINUE
SCIFV1=ALLHP(IREAL8(2))
SCIFV2=ALLHP(IREAL8(2))
SCIFV3=ALLHP(IREAL8(2))
SCIFV4=ALLHP(IREAL8(2))
SCIFV6=ALLHP(IREAL8(2))
DRATQ=ALLHP(IREAL8(2))
ERATQ=ALLHP(IREAL8(2))
E2RATQ=ALLHP(IREAL8(2))
BDRATQ=ALLHP(IREAL8(2))
INRATQ=ALLHP(INTEG4(2))
GOTO I880 ! { dg-warning "Obsolete: Assigned" "Assigned GO TO" }
920 CONTINUE
IUPD=ALLHP(INTEG4(PARDIM+3))
GOTO I920 ! { dg-warning "Obsolete: Assigned" "Assigned GO TO" }
END