1328 lines
46 KiB
Fortran
1328 lines
46 KiB
Fortran
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,'<NMDIMB>',
|
|
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,'<NMDIMB>','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,'<NMDIMB>',
|
|
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,'<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 "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,'<NMDIMB>',
|
|
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
|