c { dg-do compile } CHARMM Element source/dimb/nmdimb.src 1.1 C.##IF DIMB 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) C----------------------------------------------------------------------- C 01-Jul-1992 David Perahia, Liliane Mouawad C 15-Dec-1994 Herman van Vlijmen C C This is the main routine for the mixed-basis diagonalization. C See: L.Mouawad and D.Perahia, Biopolymers (1993), 33, 599, C and: D.Perahia and L.Mouawad, Comput. Chem. (1995), 19, 241. C The method iteratively solves the diagonalization of the C Hessian matrix. To save memory space, it uses a compressed C form of the Hessian, which only contains the nonzero elements. C In the diagonalization process, approximate eigenvectors are C mixed with Cartesian coordinates to form a reduced basis. The C Hessian is then diagonalized in the reduced basis. By iterating C over different sets of Cartesian coordinates the method ultimately C converges to the exact eigenvalues and eigenvectors (up to the C requested accuracy). C If no existing basis set is read, an initial basis will be created C which consists of the low-frequency eigenvectors of diagonal blocks C of the Hessian. C----------------------------------------------------------------------- C----------------------------------------------------------------------- C:::##INCLUDE '~/charmm_fcm/impnon.fcm' C..##IF VAX IRIS HPUX IRIS GNU CSPP OS2 GWS CRAY ALPHA IMPLICIT NONE C..##ENDIF C----------------------------------------------------------------------- C----------------------------------------------------------------------- C:::##INCLUDE '~/charmm_fcm/stream.fcm' 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 C..##IF SAVEFCM C..##ENDIF C----------------------------------------------------------------------- C----------------------------------------------------------------------- C:::##INCLUDE '~/charmm_fcm/dimens.fcm' INTEGER LARGE,MEDIUM,SMALL,REDUCE C..##IF QUANTA C..##ELIF T3D C..##ELSE PARAMETER (LARGE=60120, MEDIUM=25140, SMALL=6120) C..##ENDIF PARAMETER (REDUCE=15000) INTEGER SIZE C..##IF XLARGE C..##ELIF XXLARGE C..##ELIF LARGE C..##ELIF MEDIUM PARAMETER (SIZE=MEDIUM) C..##ELIF REDUCE C..##ELIF SMALL C..##ELIF XSMALL C..##ENDIF C..##IF MMFF 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) C..##ENDIF INTEGER MAXCSP, MAXHSET C..##IF HMCM PARAMETER (MAXHSET = 200) C..##ELSE C..##ENDIF C..##IF REDUCE C..##ELSE PARAMETER (MAXCSP = 500) C..##ENDIF C..##IF HMCM INTEGER MAXHCM,MAXPCM,MAXRCM C...##IF REDUCE C...##ELSE PARAMETER (MAXHCM=500) PARAMETER (MAXPCM=5000) PARAMETER (MAXRCM=2000) C...##ENDIF C..##ENDIF INTEGER MXCMSZ C..##IF IBM IBMRS CRAY INTEL IBMSP T3D REDUCE C..##ELSE PARAMETER (MXCMSZ = 5000) C..##ENDIF INTEGER CHRSIZ PARAMETER (CHRSIZ = SIZE) INTEGER MAXATB C..##IF REDUCE C..##ELIF QUANTA C..##ELSE PARAMETER (MAXATB = 200) C..##ENDIF INTEGER MAXVEC C..##IFN VECTOR PARVECT PARAMETER (MAXVEC = 10) C..##ELIF LARGE XLARGE XXLARGE C..##ELIF MEDIUM C..##ELIF SMALL REDUCE C..##ELIF XSMALL C..##ELSE C..##ENDIF INTEGER IATBMX PARAMETER (IATBMX = 8) INTEGER MAXHB C..##IF LARGE XLARGE XXLARGE C..##ELIF MEDIUM PARAMETER (MAXHB = 8000) C..##ELIF SMALL C..##ELIF REDUCE XSMALL C..##ELSE C..##ENDIF INTEGER MAXTRN,MAXSYM C..##IFN NOIMAGES PARAMETER (MAXTRN = 5000) PARAMETER (MAXSYM = 192) C..##ELSE C..##ENDIF C..##IF LONEPAIR (lonepair_max) INTEGER MAXLP,MAXLPH C...##IF REDUCE C...##ELSE PARAMETER (MAXLP = 2000) PARAMETER (MAXLPH = 4000) C...##ENDIF C..##ENDIF (lonepair_max) INTEGER NOEMAX,NOEMX2 C..##IF REDUCE C..##ELSE PARAMETER (NOEMAX = 2000) PARAMETER (NOEMX2 = 4000) C..##ENDIF INTEGER MAXATC, MAXCB, MAXCH, MAXCI, MAXCP, MAXCT, MAXITC, MAXNBF C..##IF REDUCE C..##ELIF MMFF CFF PARAMETER (MAXATC = 500, MAXCB = 1500, MAXCH = 3200, MAXCI = 600, & MAXCP = 3000,MAXCT = 15500,MAXITC = 200, MAXNBF=1000) C..##ELIF YAMMP C..##ELIF LARGE C..##ELSE C..##ENDIF INTEGER MAXCN PARAMETER (MAXCN = MAXITC*(MAXITC+1)/2) INTEGER MAXA, MAXAIM, MAXB, MAXT, MAXP INTEGER MAXIMP, MAXNB, MAXPAD, MAXRES INTEGER MAXSEG, MAXGRP C..##IF LARGE XLARGE XXLARGE C..##ELIF MEDIUM PARAMETER (MAXA = SIZE, MAXB = SIZE, MAXT = SIZE, & MAXP = 2*SIZE) PARAMETER (MAXIMP = 9200, MAXNB = 17200, MAXPAD = 8160, & MAXRES = 14000) C...##IF MCSS C...##ELSE PARAMETER (MAXSEG = 1000) C...##ENDIF C..##ELIF SMALL C..##ELIF XSMALL C..##ELIF REDUCE C..##ELSE C..##ENDIF C..##IF NOIMAGES C..##ELSE PARAMETER (MAXAIM = 2*SIZE) PARAMETER (MAXGRP = 2*SIZE/3) C..##ENDIF INTEGER REDMAX,REDMX2 C..##IF REDUCE C..##ELSE PARAMETER (REDMAX = 20) PARAMETER (REDMX2 = 80) C..##ENDIF 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, C..##IF YAMMP C..##ELSE & MXRTX = 5000, MXRTHA = 300, MXRTHD = 300, C..##ENDIF & MXRTBL = 5000, NICM = 10) INTEGER NMFTAB, NMCTAB, NMCATM, NSPLIN C..##IF REDUCE C..##ELSE PARAMETER (NMFTAB = 200, NMCTAB = 3, NMCATM = 12000, NSPLIN = 3) C..##ENDIF INTEGER MAXSHK C..##IF XSMALL C..##ELIF REDUCE C..##ELSE PARAMETER (MAXSHK = SIZE*3/4) C..##ENDIF INTEGER SCRMAX C..##IF IBM IBMRS CRAY INTEL IBMSP T3D REDUCE C..##ELSE PARAMETER (SCRMAX = 5000) C..##ENDIF C..##IF TSM INTEGER MXPIGG C...##IF REDUCE C...##ELSE PARAMETER (MXPIGG=500) C...##ENDIF INTEGER MXCOLO,MXPUMB PARAMETER (MXCOLO=20,MXPUMB=20) C..##ENDIF C..##IF ADUMB INTEGER MAXUMP, MAXEPA, MAXNUM C...##IF REDUCE C...##ELSE PARAMETER (MAXUMP = 10, MAXNUM = 4) C...##ENDIF C..##ENDIF INTEGER MAXING PARAMETER (MAXING=1000) C..##IF MMFF 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) C..##ENDIF C----------------------------------------------------------------------- C----------------------------------------------------------------------- C:::##INCLUDE '~/charmm_fcm/number.fcm' REAL(KIND=8) ZERO, ONE, TWO, THREE, FOUR, FIVE, SIX, & SEVEN, EIGHT, NINE, TEN, ELEVEN, TWELVE, THIRTN, & FIFTN, NINETN, TWENTY, THIRTY C..##IF SINGLE C..##ELSE 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) C..##ENDIF REAL(KIND=8) FIFTY, SIXTY, SVNTY2, EIGHTY, NINETY, HUNDRD, & ONE2TY, ONE8TY, THRHUN, THR6TY, NINE99, FIFHUN, THOSND, & FTHSND,MEGA C..##IF SINGLE C..##ELSE 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) C..##ENDIF REAL(KIND=8) MINONE, MINTWO, MINSIX PARAMETER (MINONE = -1.D0, MINTWO = -2.D0, MINSIX = -6.D0) REAL(KIND=8) TENM20,TENM14,TENM8,TENM5,PT0001,PT0005,PT001,PT005, & PT01, PT02, PT05, PTONE, PT125, PT25, SIXTH, THIRD, & PTFOUR, PTSIX, HALF, PT75, PT9999, ONEPT5, TWOPT4 C..##IF SINGLE C..##ELSE 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) C..##ENDIF REAL(KIND=8) ANUM,FMARK REAL(KIND=8) RSMALL,RBIG C..##IF SINGLE C..##ELSE PARAMETER (ANUM=9999.0D0, FMARK=-999.0D0) PARAMETER (RSMALL=1.0D-10,RBIG=1.0D20) C..##ENDIF REAL(KIND=8) RPRECI,RBIGST C..##IF VAX DEC C..##ELIF IBM C..##ELIF CRAY C..##ELIF ALPHA T3D T3E C..##ELSE C...##IF SINGLE C...##ELSE PARAMETER (RPRECI = 2.22045D-16, RBIGST = 4.49423D+307) C...##ENDIF C..##ENDIF C----------------------------------------------------------------------- C----------------------------------------------------------------------- C:::##INCLUDE '~/charmm_fcm/consta.fcm' REAL(KIND=8) PI,RADDEG,DEGRAD,TWOPI PARAMETER(PI=3.141592653589793D0,TWOPI=2.0D0*PI) PARAMETER (RADDEG=180.0D0/PI) PARAMETER (DEGRAD=PI/180.0D0) REAL(KIND=8) COSMAX PARAMETER (COSMAX=0.9999999999D0) REAL(KIND=8) TIMFAC PARAMETER (TIMFAC=4.88882129D-02) REAL(KIND=8) KBOLTZ PARAMETER (KBOLTZ=1.987191D-03) REAL(KIND=8) CCELEC C..##IF AMBER C..##ELIF DISCOVER C..##ELSE PARAMETER (CCELEC=332.0716D0) C..##ENDIF REAL(KIND=8) CNVFRQ PARAMETER (CNVFRQ=2045.5D0/(2.99793D0*6.28319D0)) REAL(KIND=8) SPEEDL PARAMETER (SPEEDL=2.99793D-02) REAL(KIND=8) ATMOSP PARAMETER (ATMOSP=1.4584007D-05) REAL(KIND=8) PATMOS PARAMETER (PATMOS = 1.D0 / ATMOSP ) REAL(KIND=8) BOHRR PARAMETER (BOHRR = 0.529177249D0 ) REAL(KIND=8) TOKCAL PARAMETER (TOKCAL = 627.5095D0 ) C..##IF MMFF REAL(KIND=8) MDAKCAL parameter(MDAKCAL=143.9325D0) C..##ENDIF REAL(KIND=8) DEBYEC PARAMETER ( DEBYEC = 2.541766D0 / BOHRR ) REAL(KIND=8) ZEROC PARAMETER ( ZEROC = 298.15D0 ) C----------------------------------------------------------------------- C----------------------------------------------------------------------- C:::##INCLUDE '~/charmm_fcm/exfunc.fcm' C..##IF ACE C..##ENDIF C..##IF ADUMB C..##ENDIF 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 C..##IF ACE * ,GETNNB C..##ENDIF LOGICAL CHKPTR, EQST, EQSTA, EQSTWC, EQWDWC, DOTRIM, CHECQUE, * HYDROG, INITIA, LONE, LTSTEQ, ORDER, ORDER5, * ORDERR, USEDDT, QTOKDEL, QDIGIT, QALPHA REAL(KIND=8) DECODF, DOTVEC, GTRMF, LENVEC, NEXTF, RANDOM, GTRR8, * RANUMB, R8VAL, RETVAL8, SUMVEC C..##IF ADUMB * ,UMFI C..##ENDIF 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 C..##IF ADUMB * ,UMFI C..##ENDIF C..##IF ACE * ,GETNNB C..##ENDIF C..##IFN NOIMAGES INTEGER IMATOM EXTERNAL IMATOM C..##ENDIF C..##IF MBOND C..##ENDIF C..##IF MMFF 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(KIND=8) vangle, OOPNGL, TORNGL, ElementMass external vangle, OOPNGL, TORNGL, ElementMass C..##ENDIF C----------------------------------------------------------------------- C----------------------------------------------------------------------- C:::##INCLUDE '~/charmm_fcm/stack.fcm' INTEGER STKSIZ C..##IFN UNICOS C...##IF LARGE XLARGE C...##ELIF MEDIUM REDUCE PARAMETER (STKSIZ=4000000) C...##ELIF SMALL C...##ELIF XSMALL C...##ELIF XXLARGE C...##ELSE C...##ENDIF INTEGER LSTUSD,MAXUSD,STACK COMMON /ISTACK/ LSTUSD,MAXUSD,STACK(STKSIZ) C..##ELSE C..##ENDIF C..##IF SAVEFCM C..##ENDIF C----------------------------------------------------------------------- C----------------------------------------------------------------------- C:::##INCLUDE '~/charmm_fcm/heap.fcm' INTEGER HEAPDM C..##IFN UNICOS (unicos) C...##IF XXLARGE (size) C...##ELIF LARGE XLARGE (size) C...##ELIF MEDIUM (size) C....##IF T3D (t3d2) C....##ELIF TERRA (t3d2) C....##ELIF ALPHA (t3d2) C....##ELIF T3E (t3d2) C....##ELSE (t3d2) PARAMETER (HEAPDM=2048000) C....##ENDIF (t3d2) C...##ELIF SMALL (size) C...##ELIF REDUCE (size) C...##ELIF XSMALL (size) C...##ELSE (size) C...##ENDIF (size) INTEGER FREEHP,HEAPSZ,HEAP COMMON /HEAPST/ FREEHP,HEAPSZ,HEAP(HEAPDM) LOGICAL LHEAP(HEAPDM) EQUIVALENCE (LHEAP,HEAP) C..##ELSE (unicos) C..##ENDIF (unicos) C..##IF SAVEFCM (save) C..##ENDIF (save) C----------------------------------------------------------------------- C----------------------------------------------------------------------- C:::##INCLUDE '~/charmm_fcm/fast.fcm' 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 C..##IF SAVEFCM C..##ENDIF C----------------------------------------------------------------------- C----------------------------------------------------------------------- C:::##INCLUDE '~/charmm_fcm/deriv.fcm' REAL(KIND=8) DX,DY,DZ COMMON /DERIVR/ DX(MAXAIM),DY(MAXAIM),DZ(MAXAIM) C..##IF SAVEFCM C..##ENDIF C----------------------------------------------------------------------- C----------------------------------------------------------------------- C:::##INCLUDE '~/charmm_fcm/energy.fcm' 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 C..##IF ACE & , SELF, SCREEN, COUL ,SOLV, INTER C..##ENDIF C..##IF FLUCQ & ,FQKIN C..##ENDIF 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 C..##IF ACE & , SELF = 45, SCREEN = 46, COUL = 47, & SOLV = 48, INTER = 49 C..##ENDIF C..##IF FLUCQ & ,FQKIN = 50 C..##ENDIF & ) C..##IF ACE C..##ENDIF C..##IF GRID C..##ENDIF C..##IF FLUCQ C..##ENDIF 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 C..##IF HMCM & , HMCM C..##ENDIF C..##IF ADUMB & , ADUMB C..##ENDIF & , HYDR C..##IF FLUCQ & , FQPOL C..##ENDIF 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 C..##IF HMCM & , HMCM = 61 C..##ENDIF C..##IF ADUMB & , ADUMB = 62 C..##ENDIF & , HYDR = 63 C..##IF FLUCQ & , FQPOL = 65 C..##ENDIF & ) 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(KIND=8) EPROP, ETERM, EPRESS COMMON /ENER/ EPROP(LENENP), ETERM(LENENT), EPRESS(LENENV) C..##IF SAVEFCM C..##ENDIF REAL(KIND=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) C..##IF SAVEFCM C..##ENDIF INTEGER ECALLS, TOT1ST, TOT2ND COMMON /EMISCI/ ECALLS, TOT1ST, TOT2ND REAL(KIND=8) EOLD, FITA, DRIFTA, EAT0A, CORRA, FITP, DRIFTP, & EAT0P, CORRP COMMON /EMISCR/ EOLD, FITA, DRIFTA, EAT0A, CORRA, & FITP, DRIFTP, EAT0P, CORRP C..##IF SAVEFCM C..##ENDIF C..##IF ACE C..##ENDIF C..##IF FLUCQ C..##ENDIF C..##IF ADUMB C..##ENDIF C..##IF GRID C..##ENDIF C..##IF FLUCQ C..##ENDIF C..##IF TSM REAL(KIND=8) TSMTRM(LENENT),TSMTMP(LENENT) COMMON /TSMENG/ TSMTRM,TSMTMP C...##IF SAVEFCM C...##ENDIF C..##ENDIF REAL(KIND=8) EHQBM LOGICAL HQBM COMMON /HQBMVAR/HQBM C..##IF SAVEFCM C..##ENDIF C----------------------------------------------------------------------- C----------------------------------------------------------------------- C:::##INCLUDE '~/charmm_fcm/dimb.fcm' C..##IF DIMB (dimbfcm) 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 C...##IF SAVEFCM C...##ENDIF C..##ENDIF (dimbfcm) C----------------------------------------------------------------------- C----------------------------------------------------------------------- C:::##INCLUDE '~/charmm_fcm/ctitla.fcm' INTEGER MAXTIT PARAMETER (MAXTIT=32) INTEGER NTITLA,NTITLB CHARACTER(80) TITLEA,TITLEB COMMON /NTITLA/ NTITLA,NTITLB COMMON /CTITLA/ TITLEA(MAXTIT),TITLEB(MAXTIT) C..##IF SAVEFCM C..##ENDIF C----------------------------------------------------------------------- C Passed variables 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(KIND=8) X(*),Y(*),Z(*),AMASS(*),DDSCR(*) REAL(KIND=8) DDV(NAT3,*),PARDDV(PARDIM,*),DDM(*),DDS(*) REAL(KIND=8) DDF(*),PARDDF(*),DDEV(*),PARDDE(*) REAL(KIND=8) DD1BLK(*),DD1BLL(*),DD1CMP(*) REAL(KIND=8) TOLDIM,DDVALM REAL(KIND=8) PARFRQ,CUTF1 LOGICAL LNOMA,LRAISE,LSCI,LBIG C Local variables 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(KIND=8) CVGMX,TOLER LOGICAL LCARD,LAPPE,LPURG,LWDINI,QCALC,QMASWT,QMIX,QDIAG C Begin 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,'', 1 'NFREG IS LARGER THAN PARDIM*3') C C ALLOCATE-SPACE-FOR-TRANSROT-VECTORS ASSIGN 801 TO I800 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } GOTO 800 801 CONTINUE C ALLOCATE-SPACE-FOR-DIAGONALIZATION ASSIGN 721 TO I720 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } GOTO 720 721 CONTINUE C ALLOCATE-SPACE-FOR-REDUCED-BASIS ASSIGN 761 TO I760 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } GOTO 760 761 CONTINUE C ALLOCATE-SPACE-FOR-OTHER-ARRAYS ASSIGN 921 TO I920 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } GOTO 920 921 CONTINUE C C Space allocation for working arrays of EISPACK C diagonalization subroutines IF(LSCI) THEN C ALLOCATE-SPACE-FOR-LSCI ASSIGN 841 TO I840 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } GOTO 840 841 CONTINUE ELSE C ALLOCATE-DUMMY-SPACE-FOR-LSCI ASSIGN 881 TO I880 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: 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. C C Mass weight DD1CMP matrix C CALL MASSDD(DD1CMP,DDM,INBCMP,JNBCMP,NATOM) ELSE CALL WRNDIE(-3,'','QDISK OPTION NOT SUPPORTED YET') C DO I=1,LENDSK C DD1CMP(I)=0.0 C ENDDO C OLDFAS=LFAST C LFAST = -1 ENDIF C C Fill DDV with six translation-rotation vectors C 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 C C If no previous basis is read C 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) C C Generate the lower section of the matrix and diagonalize C C..##IF EISPACK C..##ENDIF 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) C..##IF EISPACK C..##ENDIF C C Put the PARDDV vectors into DDV and replace the elements which do C not belong to the considered partitioned region by zeros. C 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 C C Orthonormalize the eigenvectors C OLDPRN=PRNLEV PRNLEV=1 CALL ORTHNM(1,NFRET,NFRET,DDV,NAT3,LPURG,TOLER) PRNLEV=OLDPRN C C Do reduced basis diagonalization using the DDV vectors C and get eigenvectors of zero iteration C 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) C C DO-THE-DIAGONALISATIONS-WITH-RESIDUALS C ASSIGN 621 TO I620 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } GOTO 620 621 CONTINUE C SAVE-MODES ASSIGN 701 TO I700 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: 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 C C Read in existing basis C IF(PRNLEV.GE.2) THEN WRITE(OUTU,531) 531 FORMAT(/' NMDIMB: Calculations restarted') ENDIF C READ-MODES 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,'', 1 'Not enough space to hold the basis. Increase NMODes') ENDIF C PRINT-MODES 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 C C ------------------------------------------------- C Here starts the mixed-basis diagonalization part. C ------------------------------------------------- C C C Check cut-off frequency C CALL SELNMD(DDF,NFRET,CUTF1,NFCUT1) C TEST-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) C C Compute the new partioning of the molecule C 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) C 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') C C If double windowing is defined, the original block sizes are divided C in two. C 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) C C Find out with which block to continue (double window method only) C 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 C C Main loop. C 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) C DO-THE-DIAGONALISATIONS ASSIGN 641 to I640 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } GOTO 640 641 CONTINUE QDIAG=.FALSE. C DO-THE-DIAGONALISATIONS-WITH-RESIDUALS ASSIGN 622 TO I620 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } GOTO 620 622 CONTINUE QDIAG=.TRUE. C SAVE-MODES ASSIGN 702 TO I700 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } GOTO 700 702 CONTINUE C 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 C DO-THE-DWIN-DIAGONALISATIONS ASSIGN 661 TO I660 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } GOTO 660 661 CONTINUE ENDIF IF((IRESF.EQ.SAVF).OR.(ITER.EQ.ITMX)) THEN IRESF=0 QDIAG=.FALSE. C DO-THE-DIAGONALISATIONS-WITH-RESIDUALS ASSIGN 623 TO I620 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } GOTO 620 623 CONTINUE QDIAG=.TRUE. IF((CVGMX.LE.TOLDIM).OR.(ITER.EQ.ITMX)) GOTO 600 C SAVE-MODES ASSIGN 703 TO I700 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } GOTO 700 703 CONTINUE ENDIF ENDDO ENDIF ENDDO 600 CONTINUE C C SAVE-MODES ASSIGN 704 TO I700 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: 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 C----------------------------------------------------------------------- C INTERNAL PROCEDURES C----------------------------------------------------------------------- C TO DO-THE-DIAGONALISATIONS-WITH-RESIDUALS 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) C C do reduced diagonalization with preceding eigenvectors plus C residual vectors C 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 "Deleted feature: Assigned" "Assigned GO TO" } C C----------------------------------------------------------------------- C TO DO-THE-DIAGONALISATIONS 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,'', 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 "Deleted feature: Assigned" "Assigned GO TO" } C C----------------------------------------------------------------------- C TO DO-THE-DWIN-DIAGONALISATIONS 660 CONTINUE C C Store the DDV vectors into DDVBAS C 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,'', 1 'Error in dimension of block') NFRET=NFCUT1 IF(NFRET.GT.NFREG) NFRET=NFREG C C Prepare the DDV vectors consisting of 6 translations-rotations C + eigenvectors from 7 to NFCUT1 + cartesian displacements vectors C spanning the atoms from IS1 to IS2 C 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) C 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. C IF(NFCUT.GT.NFRRES) NFCUT=NFRRES NFCUT1=NFCUT NFRET=NFCUT GOTO I660 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" } C C----------------------------------------------------------------------- C TO SAVE-MODES 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 "Deleted feature: Assigned" "Assigned GO TO" } C C----------------------------------------------------------------------- C TO ALLOCATE-SPACE-FOR-DIAGONALIZATION 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 "Deleted feature: Assigned" "Assigned GO TO" } C C----------------------------------------------------------------------- C TO ALLOCATE-SPACE-FOR-REDUCED-BASIS 760 CONTINUE IF(LBIG) THEN DDVBAS=ALLHP(IREAL8(NAT3)) ELSE DDVBAS=ALLHP(IREAL8(NFREG*NAT3)) ENDIF GOTO I760 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" } C C----------------------------------------------------------------------- C TO ALLOCATE-SPACE-FOR-TRANSROT-VECTORS 800 CONTINUE TRAROT=ALLHP(IREAL8(6*NAT3)) GOTO I800 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" } C C----------------------------------------------------------------------- C TO ALLOCATE-SPACE-FOR-LSCI 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 "Deleted feature: Assigned" "Assigned GO TO" } C C----------------------------------------------------------------------- C TO ALLOCATE-DUMMY-SPACE-FOR-LSCI 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 "Deleted feature: Assigned" "Assigned GO TO" } C C----------------------------------------------------------------------- C TO ALLOCATE-SPACE-FOR-OTHER-ARRAYS 920 CONTINUE IUPD=ALLHP(INTEG4(PARDIM+3)) GOTO I920 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" } C.##ELSE C.##ENDIF END