PROGRAM MXDORTHO C============================================================== C## ## C## Program : MXDORTHO ## C## ## C## by Katsuyuki Kawamura (Hokkaido University) ## C## (Tokyo Institute of Technology) ## C## ## C## Configuration and Energy for Non-Cubic Systems ## C## (Rectangular parallelepiped) ## C## with Pressure Control by stress tensor, ## C## and Quantum Correction for energy and pressure ## C## ## C## 2nd order interpolation from tables ## C## ## C## First cubic version on Hitac 8800/8700 1980 ## C## First orthogonal (crystal) version 1983-Oct ## C## on CDC7600 at Manchester Univ. ## C## HITAC M-280/IAP version 1985-Sep-12 ## C## PX, PY, PZ pressure control version 1987-Feb-07 ## C## Pressure tensor and ## C## fractional coordinates 1987-Oct-29 ## C## Five element and ## C## input data format and history 1987-Nov-05 ## C## PC9800RA+NDP-FORTRAN-386 version 1989-Jan-26 ## C## Reviced for JCPE 1990-Apr-14 ## C## (XDORTO : DEFECT) 1990-Apr-21 ## C## 3-body interaction (H2O, Kumagai & Kats) 1991-Feb-02 ## C## Integrated version of MD and XD (MXD) 1991-May-22 ## C## Rearranged 1991-Oct-23 ## C## Seven comonents, rearranged 1992-Jan-23 ## C## Quatum corrections (Nakao & Kats) 1992-Mar-04 ## C## Ten comonents, rearranged 1992-Mar-31 ## C## Extended Andersen's pressure control 1992-Apr-07 ## C## (Katsuta & Kats) ## C## Metal (main group) potential 1992-Apr-18 ## C## Revised for JCPE version 1992-Aug-01 ## C## 2nd order interpolation from tables 1992-Sep-05 ## C## 2nd order interpolation of velocity 1992-Dec-12 ## C## Nose's thermostat 1992-Dec-14 ## C## Correction for trancation VW-term 1993-Dec-10 ## C## Reviced 3-body by Kuma 1994-Jan-30 ## C## L-J potential 1994-Jun-28 ## C## Nose's thermostat + quantum 1994-Sep-01 ## C## Improvement of Semi-classical MD 1995-Jun-15 ## C## FILE09.DAT format changed 1995-Jul-18 ## C## IP model by Belonoshko & Dubrovinsky 1996-Sep-05 ## C## Electric Field(N.SAWAGUCHI) & Gravity F. 1997-Jun-30 ## C## Diatomic 3 chrge model 1997-Oct-20 ## C## 'ENERGY' and 'CUBE' options 1998-Aug-24 ## C## 'CONVEC' option 1999-Feb-09 ## C## 'P ANDERS-C' for cubic Andersen 1999-Aug-23 ## C## Pair type potential model (PAIR-P) 1999-Sep-27 ## C## 3-body j-i-k with j<>k 1999-Nov-16 ## C## 'EXCLUSION' : column and so on 2000-Apr-15 ## C## 3-body sqrt(k1xk2) -> k1xk2 2000-May-01 ## C## Cell change with time 2000-May-28 ## C## POSISION-VELOCITY-ENERGY option 2000-Dec-16 ## C## Soft repulsive wall 2001-Mar-07 ## C## Modify EWALD direct term 2001-Mar-24 ## C## 3-body j-i-k : modified 2001-Sep-11 ## C## File07.dat : format 2001-Dec-02 ## C## Polyatomic molecule 2002-Feb-23 ## C## Modify NETWORK analysis (c.n.=5) 2002-Sep-14 ## C## file07.dat (i10) and 3-body 2003-Jul-09 ## C## New multi-3-body 2003-Jul-28 ## C## Extended diatomic molecule (ion) 2004-Sep-26 ## C## Separate file08.dat (file081.dat) 2005-Aug-11 ## C## CUBE-F option 2005-Nov-07 ## C## temperature gradient 2007-Jul-31 ## C=========================================================================I C Format and parameters of 'FILE05.DAT' file : C-------------------------------------------------------------------------I C 1 MD.......I....:....I....:....I....:....I....:....I....:....I....:....I C XD.......I... : C 2 START :TITLE(60 CHARACTERS) : C CONTINUE : (CONT.) : C RESTART : : C STOP : : C 3 ECONOMY :IRECRD(1):IRECRD(2):IRECRD(3):IRECRD(4):IRECRD(5): : C NORMAL : : : (50) : (M50,X5): (5) : : C DETAIL : : : : : : : C 4 NOACCUM : DTIME : FORMULA : (RCUTL) : (RCUTS) : : : C ACCUM : : : : : : : C 5 T NO-CNTL: : : : : : : C T [BLANK]: : : : [No control on temperature]: C T SCALING: TMPGET : DELTMP : NTSTEP : TDUMP : : : C T SCALE-A: TMPGET : DELTMP : NTSTEP : TDUMP : [Scale each atom]: C T NOSE : TMPGET : DELTMP : STEMP : : : : C T GRAD : : : STEMP : TDUMP : [Temperature grad]: C 6 P NO-CNTL: : : : : : : C P [BLANK]: : : : [No control on pressure]: C P SCALING: SPRES(1):SPRES(2) :SPRES(3) : PDUMP : : : C P ANDERSEN SPRES(1):SPRES(2) :SPRES(3) :VIRM(1) :VIRM(2) :VIRM(3) : C P ANDERS-C SPRES(1): : :VIRM(1) : : : C 7 V [BLANK]: : : [Volume is changed with P-control]: C V CONST. : : : : [Volume is kept constant]: C V CELL : BOX(1) : BOX(2) : BOX(3) : BOX(4) : BOX(5) : BOX(6) : C V DENSITY: DENSTY : : : : : : C D CONST. : DENSTY : : : : : : C V CHANGE : ICAXIS : BTAGET : BCNGR(A par step) : : : C 8 BUSING :MODE,MXN2:(ALPHA) : : : : : C MORSE : : : : : : : C MORSEQ : : : : : : : C MORSE-AT : : : : : : : C BMH-EXP : 3-body sqrt(k1xk2) : : : : C BMH-EXP* : 3 body k1xk2 : : : : C BELONO : : : : : : : C TOSIFUMI : : : : : : : C WOODCOCK : : : : : : : C PAULING : : : : : : : C METAL : : : : : : : C PAIR-P : : : : : : : C STSUNE : : : : : : : C L-J : : : : : : : C 81 N A NO. : ZI : WI : AI : BI : CI(VW) : DI() : C - : : : : : not moved : C * : : : : : dummy atoms : C = : : : : : Morse only : C / : : : : : no T-control : C 81e[BLANK] : : : : : : : C 82 I J : DMIJ : BEIJ : RSIJ : Rswich : [Morse] : C I J : D1ij : Be1ij : D2ij : Be2ij : Rswich : i3 : C D3ij : Be3ij : r3ij : : [BMH-EXP] : C J I J :FK3BP :ANG3BP :R3BLIM :R3BGD : [3-body] : C J I K :FK3BP(1) :ANG3BP(1):R3BLIM(1):R3BGD(1) : [3-body(J<>K)]: C : : :R3BLIM(2):R3BGD(2) : : : C 82 I J : AIJ : BIJ : CIJ : : (eV) : [Pair-U]: C 82 I J : AIJ : BIJ : CIJ : (kJ/mol) : [Pair-P]: C 82e[BLANK] : : : : : : : C : : : : : : : C 91 STRUCTURE: : : 9 : : : : C 92 NETWORK :NFCION(1):NFCION(2): 10 : [Network structure analy.]: C : : : : NFCION(1) should be 2. * C : : : : NFCION(2) should be 0 or 3.: C 93 VELOCITY :NS09PV :PVMULT : 11 : [Record particle velocity] : C POSITION :NS09PV :PVMULT : 11 : [... ... position] : C ENERGY :NS09PV :PVMULT : 11 : [....... energy ] : C POSVELENE:NS09PV : : 11 : [..... pos,velo,ener] : C 94 QUANTUM : : : 12 : [Quantum correction] : C 95 PCF, RDF : ISTEP : Rend(A) : 13 : [Format of PCF table] : C*96 DIPOLE : : : 14 : [E(dipole moment)] : C 97 CENTER : : : 15 : [Centering of atom cluster]: C CENTERING: iaxcen : : : : C 98 NO(MV=0) : : : 16 : [No correction for morment]: C AM(MV=0) : Iamv : Namv : : [Moment correction for Iamv]: C : : : if Namv>0 then oly Namv atoms used : C 99 CRYSTAL : : : 17 : [MD of crystal structure] : C 9A BINARY : : : 18 : [Binary data for file09x.] : C 9B PRESSURE : NPRESS : : 19 : [Pressure tensor on file11]: C 9C ELEC.FIELD EFD1 : EFD2 : EFD3 : EFFEQ 20:[Electric field] : C 9D GRAV.FIELD GFD1 : GFD2 : GFD3 : 21:[Gravity field] : C 9E CONSTSHEAR VX-RY : VY-RZ : VX-RZ :(ps)-1 22:[Const.shear rat]: C 9F DIATOMIC : Zmole1 : DINTRA1 :iatom2(1): : : icont : C : Zmole2 : Dintra2 :iatom2(2): : : : C 23:[Diatomic molec] : C 9G CUBE : : : : 24:[to Cubic cell] : C CUBE-F : : : : : [forced CUBE] : C 9H CONVEC : FCONVC : : : 25:[Convection] : C 9I MOLECULE : Dintra :MOLstart : MOLend : 26:[Define molecule]: C 9J EXCLUSION: : : : 27:[Exclusion] : C COLUMN : iaex : Rexcl(radius) F : : R>0 out : C SLUB : iaex : Rexcl(Thickness/2) F : : R<0 in : C CUBE : Rexcl(edge/2) : Fexcl : : : : C SPHERE : Rexcl(radius) : Fexcl : : : : C HONEYCOMB: iaex : Rexcl(radius) : Fexcl : : : : C 9K WALL : A : B : : 28:[Soft repulsive wall]: C 9L POLYATOM : Dintra :MOLstart : MOLend : 29:[Polyatomic molecule]: C 9M REMOVE : RMZL : RMZH : RMVZ : 30:[Remove atom condition]: C 9N T GRAD : IAXTGR : T000 : T050 : 31:[Temperature gradient]: C 9O : : : : : : : C 9P ........ : : : : : : : C 9e [BLANK] : : : : : : : C 9 : : : : : : : C MD.......I....:....I....:....I....:....I....:....I....:....I....:....: C REPEAT 1 TO 9 : C=======================================================================I C IRECRD NRECRD : C ----------------------------- ----------------------------- : C 1 Total number of steps Current step No. from 'START' : C 2 Interval of print PCF etc. Accumulation No. of PCF etc. : C (I2=N2 when 'ACCUM') : C 3 Interval of FILE07 recording Current step number : C (default: 50) in the current job : C 4 Interval of FILE09P recording Number of records in FILE09P : C (default: 50:MD. 5:XD) : C 5 Interval of FILE09V recording Number of records in FILE09V : C (default: 5) : C 6 Number of steps of current HIST Number OF HISTRY informations : C 7-8 Not used Not used : C 9 Interval of FILE09PV recording Number of steps in FILE09PV : C=======================================================================I C I/O number FLNAME Filename : C 5 - input from keyboad : C 15 ( 5) FILE05.DAT in : C 6, * - screen output out : C 16 ( 6) FILE06.DAT out : C 17 ( 7) FILE07.DAT in/out : C 18 ( 8) FILE08.DAT in/out : C 38 (18) FILE081.DAT in/out : C 19 ( 9) FILE09P.DAT in/out : C 10 (10) FILE10.DAT in : C 29 (11) FILE09V.DAT in/out : C 28 (12) FILE09PV.DAT out : C 27 (13) FILE11.DAT out : C 22 (19) TEMPO.DAT in/out(work) : C=======================================================================I C LNI : Maximum number of particles (ion or atom) in a basic cell : C LTB : Maximum table length of Coulomb energy and force : C LSR : Table length of short range interactions : C LEL : Maximum number of particle species : C LEE : Number of pairs of particle species : C LCT : Maximum number of steps : C LNV : Maxinum number of reciprocal lattice points in EWALD sum. : C LAA : Maximum number of atoms in a asymmetric unit (XD) : C LAT : Maximum number of atoms in a crystal unit cell (XD) : C=======================================================================I C P(3,LNI) : Fractional coordinates of atoms, 0=>>>>', 5X, * '< No. of steps >---< Temperature / K >---< Pressure ', * '/ GPa >---< Date (yymmdd) >',6X,'I') 2002 FORMAT ('I',130('='),'I') 2221 FORMAT ('I ',I7,I5,I3,I7,5X, 99X, ' I') 2222 FORMAT ('I ',I7,I5,I3,I7,4X, I7,I5,I3,I7,5X, 73X, ' I') 2223 FORMAT ('I ',I7,I5,I3,I7,4X, I7,I5,I3,I7,5X, I6,I5,I3,I7,5X, * 47X, ' I') 2224 FORMAT ('I ',I7,I5,I3,I7,4X, I7,I5,I3,I7,4X, I7,I5,I3,I7,4X, * I7,I5,I3,I7, 26X, ' I') 2225 FORMAT ('I ',I7,I5,I3,I7,4X, I7,I5,I3,I7,4X, I7,I5,I3,I7,4X, * I7,I5,I3,I7,4X, I7,I5,I3,I7,' I') END C C C ======== C================================================================ F07F08 SUBROUTINE F07F08 (INOEND) PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES(3),PPXYZ(7),FJMOL, * T000,T050, IAXTGR, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /VALUES/ TVAL(LVA),TVALL(LVA),VALMAX(LVA),VAL0(LVA), * SVAL(LVA),SVALL(LVA),VALMIN(LVA), * VAL(LVA),AVA(LVA,L50), NAV,NAVT REAL *8 TVAL,SVAL,TVALL,SVALL,VALMAX,VALMIN,VAL0,VAL,AVA COMMON /RADIAL/ NRDF(LTB,LEE),IPRDF(2) INTEGER *4 NRDF COMMON /GEOMET/ DTO(2),AVTHT(12),MBR(8,8,2),NRG(9,2),ITBR(121,12), * RTO(2),SVTHT(12),NBR(8,8,2),MEB(9,2), NTT(121,12), * NTO(2),NVTHT(12),ANGL(3,12),TTAB(LST), NTBL, * ANCN(7,2) COMMON /ACOORD/ NPT, BOXO(6),NIU(LAA),P0C(3,LAT),NSYM,ISYM(LNI), * NPTP,NBOX(3),JON(LAT),PPC(3,LAT),MATM, * RS(3,3,96),PPS(3,LAT),IHEX COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME C COMMON /WORK01/ V10(3,LNI) REAL *8 V10 COMMON /TIMDAT/ KKTIME(7,2) C REAL *8 H(3,3) CHARACTER *10 RUNO18, RUNO19 CHARACTER *4 TITLE0(15), BIN CHARACTER *1 DEFECT, ANS integer *4 iform7 INTEGER *4 IYEAR,IMONTH,IDAY, IHOUR,IMINUT,ISECND,I100TH C IF (INOEND.EQ.1) GO TO 501 C --------------------------------------------- Read from FILE07.DAT C system description, coordinates and velocities iform7 = 0 OPEN (17, FILE=FLNAME(7), STATUS='OLD', * ACCESS='SEQUENTIAL', FORM='FORMATTED' ) 7 READ (17,7007) TITLE0, NJOB, BIN, * NTION, NCOMPO, (NRECRD(I),I=1,9) C IF (NTION.GT.LNI) THEN WRITE (*,*) 'Error: No. of ions (', NTION, ') is too large', * ' (LNI=', LNI, ') !!!' STOP END IF IF (NCOMPO.GT.LEL) THEN WRITE (*,*) 'Error: No. of ion species (',NCOMPO,') is ', * 'too large (LEL=',LEL,') !!!' STOP END IF RUNOPT(18) = ' ' IF (BIN.EQ.'BIN ') RUNOPT(18) = 'BINARY ' C READ (17,7017) (ATOM(I),I=1,NCOMPO) READ (17,7018) (NION(I),I=1,NCOMPO) READ (17,7018) (IONS(1,I),I=1,NCOMPO) READ (17,7018) (IONS(2,I),I=1,NCOMPO) READ (17,7070) TEMP, DELTMP,TMPGET, SPRES, * DTIME, RUNOPT(51), BOX, * DENSTY, RUNOPT(52), VBOX IF (RUNOPT(51).EQ.'THERMOSTAT') READ (17,7080) STEMP, VSTEMP IF (RUNOPT(52).EQ.'H-TENSOR ') THEN DO 100 I = 1, 3 READ (17,7080) (H(I,J),J=1,3) 100 CONTINUE END IF c if (iform7.eq.0) then WRITE (*,1177) TITLE0, TITLE 1177 FORMAT (6X,14('='),' Titles in FILE07.DAT and FILE05.DAT are ', * 14('=') / '=====[F7]: ',15A4,' =====' / * '=====[F5]: ',15A4,' =====' ) end if C CT ------------------- delete this block-if in case of oblique system IF (BOX(4)**2+BOX(5)**2+BOX(6)**2.GT.1.E-6) THEN WRITE (*,*) 'Error: The box shape is not suitable for ', * 'MXDORTO !!!' WRITE (*,1131) BOX(4),BOX(5),BOX(6) 1131 FORMAT (' BOX(4 to 6) are ',3F12.7) WRITE (*,*) 'Is it posibble to change BOX(4), BOX(5), and', * ' BOX(6) as zero ? (y/n)' READ (5,1141) ANS 1141 FORMAT (A1) IF (ANS.EQ.'n' .OR. ANS.EQ.'N') STOP BOX(4) = 0.0 BOX(5) = 0.0 BOX(6) = 0.0 END IF C IF (NTION.GT.LNI) WRITE (*,*) 'The number of atoms :',NTION, * ' is greater than LNI:',LNI NTIOND = 0 DO 110 I = 1, NTION IOND(I) = 1 if (iform7.eq.0 ) then READ (17,7700,err=7878) (P(J,I),J=1,3), * DEFECT, (V10(J,I),J=1,3), (P0(J,I),J=1,3) else READ (17,7702,err=7878) (P(J,I),J=1,3), * DEFECT, (V10(J,I),J=1,3), (P0(J,I),J=1,3) end if if (abs(V10(1,i)-5.0)+abs(V10(2,i)-5.0)+ * abs(V10(3,i)-5.0) .gt. 3.0 ) then if (iform7.eq.1) then write (6,*) i,'-th atom is strange' stop end if iform7 = 1 rewind 17 go to 7 end if IF (DEFECT.NE.' ') THEN IOND(I) = 0 NTIOND = NTIOND + 1 V10(1,I) = 0.0D0 V10(2,I) = 0.0D0 V10(3,I) = 0.0D0 END IF DO 105 J = 1, 3 V(J,I) = (V10(J,I)-5.0D0) * 0.1D0 105 CONTINUE 110 CONTINUE IF (NTIOND.GT.0) WRITE (*,7979) NTIOND 7979 FORMAT (1X,I6,' DEFECTS WERE DETECTED ') IF (NRECRD(6).GT.0) THEN READ (17,7800,END=180,ERR=180) ((IHISTR(J,I),J=1,4), * I=1,NRECRD(6)) GO TO 190 180 NRECRD(6) = 0 190 END IF IRECRD(6) = 0 CLOSE (17) if (iform7.eq.0) write (6,*) 'Format of file07.dat will be ', * 'converted.' c go to 201 7878 write (6,*) 'File07.dat : error at the line ',i+9 stop C 201 IF (RUNOPT(2).EQ.'RESTART ') THEN RUNOPT(2) = 'START ' NRECRD(6) = 0 DO 210 I = 1,NTION DO 210 J = 1, 3 P(J,I) = P0(J,I) 210 CONTINUE END IF C NBOX(1) = 1 NBOX(2) = 1 NBOX(3) = 1 IF (RUNOPT(17).EQ.'CRYSTAL ') CALL FILE10 C IF (TITLE(1).NE.'BENC' .OR. * TITLE(2).NE. 'HMAR' ) THEN C file09p.dat : COORDINATES AT EACH 5 STEP OPEN (19, FILE=FLNAME(9), STATUS='UNKNOWN', * ACCESS='SEQUENTIAL', FORM='FORMATTED' ) C file09v.dat : VALUES AT EACH 5 STEP OPEN (29, FILE=FLNAME(11), STATUS='UNKNOWN', * ACCESS='SEQUENTIAL', FORM='FORMATTED' ) END IF C IF (RUNOPT(2).EQ.'CONTINUE '.OR.RUNOPT(2).EQ.'CONTINUE ') THEN NJOB(2) = NJOB(2) + 1 C ----------------------------------- Read from FILE08.DAT C PCF, properties, etc. OPEN (18, FILE=FLNAME(8), STATUS='OLD', * ACCESS='SEQUENTIAL', FORM='FORMATTED' ) REWIND 18 READ (18,8001) NCUT0,NRCUT(1),NRECRD(2),NAV,NAVT,NTBL, * MXCUT,NPAIR DO 301 J = 1, LEE DO 301 N = 1, LTB NRDF(N,J) = 0 301 CONTINUE DO 311 I = NCUT0, NRCUT(1) READ (18,8001) (NRDF(I,J),J=1,NPAIR) 311 CONTINUE DO 321 I = 1, LVA READ (18,8003) TVAL(I),SVAL(I),SVALL(I),VAL0(I) 321 CONTINUE c DO 331 I = 1, NAV c READ (18,8003) (AVA(J,I),J=1,LVA) c 331 CONTINUE READ (18,8003) (AU(I),I=1,NTION) DO 341 I = 1, 12 READ (18,8003) (ANGL(J,I),J=1,3) 341 CONTINUE DO 351 K = 1, 2 DO 351 J = 1, 8 READ (18,8001) (MBR(I,J,K),I=1,8) 351 CONTINUE DO 361 J = 1, 2 READ (18,8001) (NRG(I,J),I=1,9) 361 CONTINUE DO 371 I = 1, 121 READ (18,8005) (ITBR(I,J),J=1,12) 371 CONTINUE IF (RUNOPT(17).EQ.'CRYSTAL ') THEN READ (18,8004) ((PPC(J,N),J=1,3), * (PPS(J,N),J=1,3),N=1,NPT) END IF CLOSE (18) c OPEN (38, FILE=FLNAME(18), STATUS='OLD', * ACCESS='SEQUENTIAL', FORM='FORMATTED' ) REWIND 38 DO 331 I = 1, NAV READ (38,8003) (AVA(J,I),J=1,LVA) 331 CONTINUE close (38) C CALL FILE09 ELSE NJOB(1) = NJOB(1) + 1 NJOB(2) = 1 NRECRD(4) = 0 NRECRD(5) = 0 IF (TITLE(1).NE.'BENC' .OR. * TITLE(2).NE. 'HMAR' ) THEN REWIND 29 REWIND 19 END IF END IF RETURN C C ========================================= Output file07 and file08 501 NRECRD(6) = NRECRD(6) + 1 CALL KCLOCK (IYEAR,IMONTH,IDAY,IHOUR,IMINUT,ISECND,I100TH) IHISTR(1,NRECRD(6)) = IRECRD(6) IHISTR(2,NRECRD(6)) = INT(TMPGET) IHISTR(3,NRECRD(6)) = INT((SPRES(1)+SPRES(2)+SPRES(3))/3.0) IHISTR(4,NRECRD(6)) = IYEAR*10000 + IMONTH*100 + IDAY IRECRD(6) = 0 IF (NRECRD(6).GT.1) THEN KHIST = NRECRD(6) - 1 IF (IHISTR(2,NRECRD(6)).EQ.IHISTR(2,KHIST).AND. * IHISTR(3,NRECRD(6)).EQ.IHISTR(3,KHIST)) THEN IHISTR(1,KHIST)=IHISTR(1,NRECRD(6))+IHISTR(1,KHIST) IHISTR(4,KHIST)=IHISTR(4,NRECRD(6)) NRECRD(6) = KHIST END IF END IF IF (TITLE(1).EQ.'BENC' .AND. * TITLE(2).EQ. 'HMAR' ) GO TO 699 C RUNO18 = ' ' RUNO19 = ' ' IF (RUNOPT(5).EQ.'T NOSE ') RUNO18 = 'THERMOSTAT' C C ---------------------------------------------- Write on FILE07.DAT C system description, coordinates and velocities C OPEN (17, FILE=FLNAME(7), STATUS='UNKNOWN', * ACCESS='SEQUENTIAL', FORM='FORMATTED' ) REWIND 17 BIN = ' ' IF (RUNOPT(18).EQ.'BINARY ') BIN = 'BIN ' WRITE (17,7007) TITLE, NJOB, BIN, * NTION, NCOMPO, (NRECRD(I),I=1,9) WRITE (17,7017) (ATOM(I),I=1,NCOMPO) WRITE (17,7018) (NION(I),I=1,NCOMPO) WRITE (17,7018) (IONS(1,I),I=1,NCOMPO) WRITE (17,7018) (IONS(2,I),I=1,NCOMPO) WRITE (17,7070) TEMP, DELTMP,TMPGET, SPRES, * DTIME, RUNO18, BOX, * DENSTY, RUNO19, VBOX IF (RUNO18.EQ.'THERMOSTAT') WRITE (17,7080) STEMP,VSTEMP do 508 io = 1, ncompo DO 507 I = ions(1,io), ions(2,io) DO 505 J = 1, 3 V10(J,I) = V(J,I) * 10.0D0 + 5.0D0 505 CONTINUE DEFECT = ' ' IF (IOND(I).EQ.0) DEFECT = '*' WRITE (17,7702) (P(J,I),J=1,3),DEFECT,(V10(J,I),J=1,3), * (P0(J,I),J=1,3), io 507 CONTINUE 508 continue WRITE (17,7800) ((IHISTR(J,I),J=1,4),I=1,NRECRD(6)) ENDFILE (17) REWIND 17 CLOSE (17) C C -------------------------------------------- Write on FILE08.DAT C PCF, properties, etc. DO 512 N = 1, NRCUT(1) DO 511 J = 1, LEE IF (NRDF(N,J).GT.0) GO TO 513 511 CONTINUE 512 CONTINUE 513 NCUT0 = N - 1 NPAIR = NCOMPO * (NCOMPO+1) / 2 OPEN (18, FILE=FLNAME(8), STATUS='UNKNOWN', * ACCESS='SEQUENTIAL', FORM='FORMATTED' ) REWIND 18 WRITE (18,8001) NCUT0,NRCUT(1),NRECRD(2),NAV,NAVT,NTBL,MXCUT, * NPAIR DO 611 I = NCUT0, NRCUT(1) WRITE (18,8001) (NRDF(I,J),J=1,NPAIR) 611 CONTINUE DO 621 I = 1, LVA WRITE (18,8003) TVAL(I),SVAL(I),SVALL(I),VAL0(I) 621 CONTINUE c DO 631 I = 1, NAV c WRITE (18,8003) (AVA(J,I),J=1,LVA) c 631 CONTINUE WRITE (18,8003) (AU(I),I=1,NTION) DO 641 I = 1, 12 WRITE (18,8003) (ANGL(J,I),J=1,3) 641 CONTINUE DO 651 K = 1, 2 DO 651 J = 1, 8 WRITE (18,8001) (MBR(I,J,K),I=1,8) 651 CONTINUE DO 661 J = 1, 2 WRITE (18,8001) (NRG(I,J),I=1,9) 661 CONTINUE DO 671 J = 1, 121 WRITE (18,8005) (ITBR(J,I),I=1,12) 671 CONTINUE IF (RUNOPT(17).EQ.'CRYSTAL ') THEN WRITE (18,8004) ((PPC(J,N),J=1,3), * (PPS(J,N),J=1,3),N=1,NPT) END IF C ENDFILE (18) REWIND 18 CLOSE (18) c OPEN (38, FILE=FLNAME(18), STATUS='UNKNOWN', * ACCESS='SEQUENTIAL', FORM='FORMATTED' ) REWIND 38 DO 631 I = 1, NAV WRITE (38,8003) (AVA(J,I),J=1,LVA) 631 CONTINUE ENDFILE (38) REWIND 38 CLOSE (38) C 699 WRITE (*,4001) IRECRD(1) 4001 FORMAT (15('='),' Files were updated ',12('='), * ' End=',I7,2X,15('=')) WRITE (*,1178) TITLE 1178 FORMAT ('<<<===== ',15A4,' ====>>>') RETURN C C -------------------------------------------- Formats of file07.dat 7007 FORMAT (15A4,2I5,1X, A4 / I7,I3, 9I10) 7017 FORMAT (10(2X,A4) ) 7018 FORMAT (10I6 ) 7070 FORMAT (F10.2,F10.4,F10.2, 3F10.5 / * E10.3, A10, 6F10.6 / * F10.6, A10, 6F10.6 ) 7080 FORMAT (10X,3F20.10) 7700 FORMAT (3F9.7, A1, 3F8.6, 1X, 3F9.6) 7701 format (3F9.7, A1, 3F8.6, 1X, 3F9.6, 1x,i2) 7702 format (3F10.8, A1, 3F9.7, 1X, 3F10.6, 1x,i2) 7800 FORMAT (3(I10,I5,I4,1X,I6)) C -------------------------------------------- Formats of file08.dat 8001 FORMAT (10I10) 8003 FORMAT (1P5E16.9) 8004 FORMAT (0P3F12.6,4X,3F12.6) 8005 FORMAT (12I6) END C C C ======== C================================================================ FILE09 SUBROUTINE FILE09 PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /VALUES/ TVAL(LVA),TVALL(LVA),VALMAX(LVA),VAL0(LVA), * SVAL(LVA),SVALL(LVA),VALMIN(LVA), * VAL(LVA),AVA(LVA,L50), NAV,NAVT REAL *8 TVAL,SVAL,TVALL,SVALL,VALMAX,VALMIN,VAL0,VAL,AVA COMMON /ACOORD/ NPT, BOXO(6),NIU(LAA),P0C(3,LAT),NSYM,ISYM(LNI), * NPTP,NBOX(3),JON(LAT),PPC(3,LAT),MATM, * RS(3,3,96),PPS(3,LAT),IHEX COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME C COMMON /WORK02/ IP(3,LNI), PP(3,LNI) C REAL *8 H(3,3), VALVAL(LVA) C IF (TITLE(1).EQ.'BENC' .AND. * TITLE(2).EQ. 'HMAR' ) RETURN C --------------------------------------- Work file for continuation OPEN (22, FILE = FLNAME(19), STATUS = 'UNKNOWN', * ACCESS = 'SEQUENTIAL', FORM = 'FORMATTED' ) C C -------------------------------------------- FILE09V.DAT 1991 FORMAT (F8.2,7F8.4 / 8F9.2 / F9.5, F9.3, 3F9.5,3F9.6 / * 10F8.2 / 10F8.3 ) REWIND 29 REWIND 22 DO 410 K = 1, NRECRD(5) READ (29,1991) (VALVAL(I),I=1,LVA) WRITE (22,1991) (VALVAL(I),I=1,LVA) 410 CONTINUE ENDFILE 22 REWIND 29 REWIND 22 DO 420 K = 1, NRECRD(5) READ (22,1991) VALVAL WRITE (29,1991) VALVAL 420 CONTINUE C C -------------------------------------------------- FILE09P.DAT IF (RUNOPT(18).EQ.'BINARY ') THEN CLOSE (22) OPEN (22, FILE = FLNAME(19), STATUS = 'UNKNOWN', * ACCESS = 'SEQUENTIAL', FORM = 'UNFORMATTED' ) END IF MMMMM = NTION IF (RUNOPT(17).EQ.'CRYSTAL ') MMMMM = NPTP REWIND 19 REWIND 22 IF (RUNOPT(18).EQ.'BINARY ') THEN DO 440 K = 1, NRECRD(4) READ (19) L, H READ (19) ((PP(J,I),J=1,3),I=1,MMMMM) WRITE (22) L, H WRITE (22) ((PP(J,I),J=1,3),I=1,MMMMM) 440 CONTINUE REWIND 19 REWIND 22 DO 450 K = 1, NRECRD(4) READ (22) L, H READ (22) ((PP(J,I),J=1,3),I=1,MMMMM) WRITE (19) L, H WRITE (19) ((PP(J,I),J=1,3),I=1,MMMMM) 450 CONTINUE ELSE DO 460 K = 1, NRECRD(4) READ (19,9002) L, H READ (19,9001) ((IP(J,I),J=1,3),I=1,MMMMM) WRITE (22,9002) L, H WRITE (22,9001) ((IP(J,I),J=1,3),I=1,MMMMM) 460 CONTINUE REWIND 19 REWIND 22 DO 470 K = 1, NRECRD(4) READ (22,9002) L, H READ (22,9001) ((IP(J,I),J=1,3),I=1,MMMMM) WRITE (19,9002) L, H WRITE (19,9001) ((IP(J,I),J=1,3),I=1,MMMMM) 470 CONTINUE END IF C CLOSE (22) RETURN C ----------------------------------------- Formats of file09a.dat's 9001 FORMAT (18I4) 9002 FORMAT (I7,3X, 9F7.3) END C C C ======== C================================================================ FILE10 SUBROUTINE FILE10 PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /ACOORD/ NPT, BOXO(6),NIU(LAA),P0C(3,LAT),NSYM,ISYM(LNI), * NPTP,NBOX(3),JON(LAT),PPC(3,LAT),MATM, * RS(3,3,96),PPS(3,LAT),IHEX COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME C CHARACTER *4 HEX C C ------------------------------ Input file of xtal geometry OPEN (10,FILE=FLNAME(10),STATUS='OLD', * ACCESS='SEQUENTIAL',FORM='FORMATTED') REWIND 10 READ (10,5010) BOXO, * NBOX,NPT,NPTP,NSYM,HEX,MATM READ (10,5012) (ATMXTL(J),J=1,MATM) READ (10,5014) (NIU(J),J=1,MATM) READ (10,5020) (JON(N),(P0C(J,N),J=1,3),N=1,NPTP) READ (10,5030) (((RS(J,I,N),J=1,3),I=1,3),N=1,NSYM) READ (10,5040) (ISYM(N),N=1,NTION) REWIND 10 CLOSE (10) IHEX = 0 IF (HEX.EQ.'HEX ') IHEX = 1 RETURN 5010 FORMAT (3F10.7,3F10.8 / 6I5,5X,A4,I6 ) 5012 FORMAT ( 18A4 ) 5014 FORMAT ( 18I4 ) 5020 FORMAT (I5,3F10.7) 5030 FORMAT (9F6.1) 5040 FORMAT (12I6) END C C C ======== C================================================================ INITIA SUBROUTINE INITIA (INOEND) PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C C -------------------------------------------- Initial reading, etc. C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES(3),PPXYZ(7),FJMOL, * T000,T050, IAXTGR, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /BOXCNG/ BTAGET, BCNGR, ICAXIS COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME COMMON /VECTOR/ FNV(LNV),UNV(LNV),PNV(6,LNV),ZIA(LEM),UCSELF, * ALPHA, UCSLFI(LEM), MODE, NVN, NVEC(3,LNV) REAL *8 FNV,UNV,PNV,ZIA,UCSELF,ALPHA,UCSLFI COMMON /VALUES/ TVAL(LVA),TVALL(LVA),VALMAX(LVA),VAL0(LVA), * SVAL(LVA),SVALL(LVA),VALMIN(LVA), * VAL(LVA),AVA(LVA,L50), NAV,NAVT REAL *8 TVAL,SVAL,TVALL,SVALL,VALMAX,VALMIN,VAL0,VAL,AVA COMMON /RADIAL/ NRDF(LTB,LEE),IPRDF(2) INTEGER *4 NRDF COMMON /GEOMET/ DTO(2),AVTHT(12),MBR(8,8,2),NRG(9,2),ITBR(121,12), * RTO(2),SVTHT(12),NBR(8,8,2),MEB(9,2), NTT(121,12), * NTO(2),NVTHT(12),ANGL(3,12),TTAB(LST), NTBL, * ANCN(7,2) COMMON /PARAMT/ AIO(LEM),BIO(LEM),CIO(LEM),DIO(LEM),ZIO(LEM), * AIJ(LEF),BIJ(LEF),CIJ(LEF),DIJ(LEF),D4IJ(LEF), * PLIJ(LEF),RSWTCH(LEF),ZIJ(LEF), D7IJ(LEF), * ECORR,VCORR, WIO(LEM), TWEGHT, AKFI(LEM), * ANG3BP(L3P), R3BLIM(2,L3P), * FK3BP(L3P), R3BGRD(2,L3P), R3lim(2,l3p),r3limax, * I3BP(3,L3P), N3BP COMMON /TABLES/ F1(LSR,LEE),E1(LSR,LEE),F0(LTB),E0(LTB) REAL *8 F1,E1,F0,E0 common /STRCTU/ lentab COMMON /OUTERF/ EFD(3), EFREQ, GFD(3), fconvc, MEFD REAL *8 EFD, EFREQ, GFD COMMON /MOLECU/ ZMOLE(2), DMOLE(4,LNI), DINTRA(2), * NDMOLE, IDMOLE(3,LNI), IATOM2(2), MOLstart(2), * NMOLE, IMOLE(38,LNI), MMOLE(LNI), MOLend(2) real *8 zmole,dmole common /EXCLUS/ REXCL, Fexcl, iaex, iextype common /WALLP/ WALLa, WALLb common /REMOVE/ RMZL,RMZH,RMVZ COMMON /WORK01/ VV(3,LNI),DUM(3,LNI) COMMON /WORK02/ IPV(3,LNI),IDUMMY(3,LNI) C REAL *8 BOXA(6), FA(3) CHARACTER *4 AAX, ATY, THS1,THS2, RUNOP1 CHARACTER *10 RUNRUN, DUMMY ATMNET(1) = ' ' ATMNET(2) = ' ' DO 10 I = 1, 53 RUNOPT(I) = ' ' 10 CONTINUE NRECRD(9) = 0 do i=1, 2 dintra(i) =0.0 iatom2(i) =0 zmole(i) =0.0 MOLstart(i)=0 MOLend(i) =0 end do C C --------------------------------------- Data input from FILE05.DAT C IP0 = 0 INOEND = 0 30 READ (15,1001,END=888) RUNOPT(1) RUNOP1 = RUNOPT(1) IF (RUNOP1.EQ.'MDX.' .or. * RUNOP1.EQ.'mdx.') THEN RUNOPT(1) = 'MD........' RUNOP1 = 'MD..' IP0 = 1 END IF IF (RUNOP1.EQ.'MD..' .or. * RUNOP1.EQ.'md..') THEN RUNOPT(1) = 'MD........' RUNOPT(17) = 'AMORPHOUS ' END IF IF (RUNOP1.EQ.'XD..' .or. * RUNOP1.EQ.'xd..') THEN RUNOPT(1) = 'XD........' RUNOPT(17) = 'CRYSTAL ' END IF IF (RUNOP1.NE.'MD..' .AND. * RUNOP1.NE.'XD..' ) GO TO 30 READ (15,1001,END=888) RUNOPT(2),TITLE IF (RUNOPT(2).EQ.' ' .OR. * RUNOPT(2).EQ.'STOP ' .OR. * RUNOPT(2).EQ.'stop ' .OR. * RUNOPT(2).EQ.'END ' ) GO TO 888 IF (RUNOPT(2).EQ.'CONT. ' .or. * runopt(2).eq.'cont. ' .or. * runopt(2).eq.'CONTIMUE ' .or. * runopt(2).eq.'continue ') * RUNOPT(2) = 'CONTINUE ' GO TO 50 C 888 INOEND = -1 RETURN C C -------------------------------- Read file07.dat, file08.dat, etc. 50 CALL F07F08 (INOEND) C -------------------------------------- Input file of xtal geometry CALL TITLET (1,1) C ------------------------------------------- Economy, normal detail READ (15,1000) RUNOPT(3), AREC1, AREC2, AREC3, AREC4, AREC5 if (runopt(3).eq.'economy ') runopt(3)='ECONOMY ' if (runopt(3).eq.'normal ') runopt(3)='NORMAL ' if (runopt(3).eq.'detail ') runopt(3)='DETAIL ' IRECRD(1) = INT(AREC1) IRECRD(2) = INT(AREC2) IRECRD(3) = INT(AREC3) IRECRD(4) = INT(AREC4) IRECRD(5) = INT(AREC5) IF (IRECRD(1).GT.LCT) THEN WRITE (6,*) 'The number of steps:',IRECRD(1), * 'is too large (LCT=',LCT,')' WRITE (6,*) 'Please chage all the LCT parameters' STOP END IF IF (IRECRD(1).LT.IRECRD(2)) IRECRD(2) = IRECRD(1) IF (MOD(IRECRD(1),IRECRD(2)).NE.0) IRECRD(2) = IRECRD(1) IF (IRECRD(3).LE.0) IRECRD(3) = 50 IF (IRECRD(2).LT.IRECRD(3)) IRECRD(3) = IRECRD(2) IF (IRECRD(4).LE.0) THEN IF (RUNOP1.EQ.'MD......') IRECRD(4) = IRECRD(3) IF (RUNOP1.EQ.'XD......') IRECRD(4) = 5 END IF IF (IRECRD(5).LE.0) IRECRD(5) = 5 C ------------------------------------------------- Accume, noaccume READ (15,1000) RUNOPT(4), DDT, FORMUL, RCUT(1), RCUT(2) C ------------------------------------------------------ Temperature READ (15,1000) RUNRUN, TARGT, DELT, STEMP0, TDUMP IF (RUNRUN.EQ.'T ') RUNOPT(5) = 'T NO-CNTL ' IF (RUNRUN.EQ.'T NO ') RUNOPT(5) = 'T NO-CNTL ' IF (RUNRUN.EQ.'T NO-CNTL ') RUNOPT(5) = 'T NO-CNTL ' IF (RUNRUN.EQ.'T NO-SCALE') RUNOPT(5) = 'T NO-CNTL ' IF (RUNRUN.EQ.'T SCALING ' .or. * RUNRUN.EQ.'T scaling ') THEN RUNOPT(5) = 'T SCALING ' NTSTEP = STEMP0 IF (NTSTEP.LE.0) NTSTEP = 10 END IF IF (RUNRUN.EQ.'T SCALE-A ') THEN RUNOPT(5) = 'T SCALE-A ' NTSTEP = STEMP0 IF (NTSTEP.LE.0) NTSTEP = 10 END IF IF (RUNRUN.EQ.'T NOSE ' .or. * runrun.eq.'T Nose ') RUNOPT(5) = 'T NOSE ' IF (RUNRUN.EQ.'T GRAD ' .or. * runrun.eq.'T grad ') RUNOPT(5) = 'T GRAD ' IF (NTSTEP.LE.0) NTSTEP = 1 DELTMP = DELT TMPGET = TARGT IF (TDUMP.LE.0.0001) TDUMP = 0.5 IF (RUNOPT(5) .NE.'T NOSE ' .OR. * RUNOPT(2) .NE.'CONTINUE ' .OR. * RUNOPT(51).NE.'THERMOSTAT' ) THEN STEMP = STEMP0 VSTEMP = 0.0 END IF C --------------------------------------------------------- Pressure READ (15,1000) RUNRUN, SPRES, VIRM(1), VIRM(2), VIRM(3) IF (RUNRUN.EQ.'P ') RUNOPT(6) = 'P NO-CNTL ' IF (RUNRUN.EQ.'P NO ') RUNOPT(6) = 'P NO-CNTL ' IF (RUNRUN.EQ.'P NO-CNTL ') RUNOPT(6) = 'P NO-CNTL ' IF (RUNRUN.EQ.'P SCALING ' .or. * runrun.eq.'P scaling ') then RUNOPT(6) = 'P SCALING ' pdump = virm(1) if (pdump.lt.0.001) pdump = 1.0 end if IF (RUNRUN.EQ.'P ANDERSEN' .OR. * runrun.eq.'P Andersen' .OR. * RUNRUN.EQ.'P ANDERS-C' ) THEN if (RUNRUN.EQ.'P ANDERSEN') RUNOPT(6) = 'P ANDERSEN' if (RUNRUN.EQ.'P Andersen') RUNOPT(6) = 'P ANDERSEN' if (RUNRUN.EQ.'P ANDERS-C') RUNOPT(6) = 'P ANDERS-C' IF (ABS(VBOX(2)).LT.1.0E-9.AND. * ABS(VBOX(3)).LT.1.0E-9 ) THEN VBOX(1) = 0.0 VBOX(2) = 0.0 VBOX(3) = 0.0 END IF END IF C -------------------------------------------- IF (RUNOPT(6).NE.'P ANDERSEN'.AND. * ABS(VBOX(2)).GT.1.0E-9.AND. * ABS(VBOX(3)).GT.1.0E-9 ) THEN VBOX(1) = 0.0 VBOX(2) = 0.0 VBOX(3) = 0.0 END IF C ----------------------------------------------------------- Volume READ (15,1000) RUNRUN, BOXA IF (RUNRUN.EQ.' ') RUNOPT(7) = 'V FREE ' IF (RUNRUN.EQ.'V CONST. ' .or. * runrun.eq.'V const. ' .or. * runrun.eq.'V CONSTANT' .or. * runrun.eq.'V constant') RUNOPT(7) = 'V CONST. ' IF (RUNRUN.EQ.'V CONTROL ') RUNOPT(7) = 'V CONST. ' IF (RUNRUN.EQ.'D CONST. ') RUNOPT(7) = 'D CONST. ' IF (RUNRUN.EQ.'D CONTROL ') RUNOPT(7) = 'D CONST. ' C --------------------------------------- Change cell size IF (RUNRUN.EQ.'V CELL ' .or. * runrun.eq.'V cell ') THEN RUNOPT(7) = 'V CELL ' DO 400 J = 1, 3 FA(J) = BOXA(J) / BOX(J) BOX(J) = BOXA(J) 400 CONTINUE C ----------------------------------------- Change density ELSE IF (RUNRUN.EQ.'V DENSITY ' .or. * runrun.eq.'V density ') THEN RUNOPT(7) = 'V DENSITY ' FA(1) = (DENSTY/BOXA(1))**(1.0/3.0) FA(2) = FA(1) FA(3) = FA(1) DO 440 I = 1, 3 BOX(I) = BOX(I) * FA(I) 440 CONTINUE C ---------------------------------------- Uniaxizl change ELSE IF (RUNRUN.EQ.'V CHANGE ' .or. * runrun.eq.'V change ') THEN RUNOPT(7) = 'V CHANGE ' ICAXIS = BOXA(1) BTAGET = BOXA(2) BCNGR = BOXA(3) if (ABS(BCNGR).le.1.0E-6) * BCNGR = sign(1.0,BCNGR)*1.0E-6 END IF C C -------------------------------------------------- Potential model READ (15,1000) RUNOPT(8), AMODE, ALPHA MODE = INT(AMODE) IF (RUNOPT(8).NE.' ' .AND. * RUNOPT(8).NE.'BUSING ' .AND. * RUNOPT(8).NE.'MORSE ' .AND. * RUNOPT(8).ne.'MORSEQ ' .and. * RUNOPT(8).NE.'MORSE-AT ' .AND. * RUNOPT(8).NE.'BMH-EXP ' .AND. * RUNOPT(8).NE.'BMH-EXP* ' .AND. * RUNOPT(8).NE.'BMH-EXPQ ' .AND. * RUNOPT(8).NE.'BELONO ' .AND. * RUNOPT(8).NE.'TOSIFUMI ' .AND. * RUNOPT(8).NE.'WOODCOCK ' .AND. * RUNOPT(8).NE.'PAULING ' .AND. * RUNOPT(8).NE.'STSUNE ' .AND. * RUNOPT(8).NE.'L-J ' .AND. * RUNOPT(8).NE.'PAIR-P ' .AND. * RUNOPT(8).NE.'METAL ' ) THEN WRITE (*,*) 'Interatomic potential model ', * runopt(8),' is not recognized' STOP END IF C ZSUM = 0.0 DO 110 I = 1, LEM ATOM(I) = ' ' ZIO(I) = 0.0 WIO(I) = 0.0 AIO(I) = 0.0 BIO(I) = 0.0 CIO(I) = 0.0 DIO(I) = 0.0 NION(I) = 0 IION(I) = 0 110 CONTINUE NCOMPO = 0 C --------------------------------------------- Read atom parameters DO 220 J = 1, LEL+1 READ (15,1300,END=230) I,ATY,AAX,ANJ,ZJ,WJ,AJ,BJ,CJ,DJ IF (I.LE.0.OR.AAX.EQ.' ') GO TO 230 ATOM(I) = AAX ZIO(I) = ZJ WIO(I) = WJ AIO(I) = AJ BIO(I) = BJ CIO(I) = CJ DIO(I) = DJ NION(I) = INT(ANJ) IION(I) = 0 IF (I.NE.1) ZSUM = ZSUM + ZJ * ANJ IF (ATY.EQ.'-') IION(I) = -1 ! P-fixed IF (ATY.EQ.'*') IION(I) = -999 ! dummy atom IF (ATY.EQ.'=') IION(I) = 1 ! Morse only IF (ATY.EQ.'/') IION(i) = 2 ! no T-control NCOMPO = NCOMPO + 1 220 CONTINUE 230 ZI1 = - ZSUM / REAL(NION(1)) IF (ABS(ZI1-ZIO(1)).GT.0.00001) THEN WRITE (*,*) 'Warnning on total charge neutralization! ', * ZIO(1),ZI1 C ZIO(1) = ZI1 END IF IO1 = NCOMPO + 1 DO 240 IO = IO1, LEL IF (NION(IO).GT.0) NCOMPO = IO 240 CONTINUE C ------------------------------------------------------------------ DTMO = DTIME IF (RUNOPT(2).EQ.'START ') THEN IF (DDT.GT.0.0001) DTIME = DDT * 1.0E-15 IF (DTIME.LT.1.0E-18) DTIME = 2.0E-15 IF (RUNOP1.EQ.'MD..'.AND.IP0.EQ.0) THEN DO 330 I = 1,NTION DO 330 J = 1, 3 P0(J,I) = P(J,I) 330 CONTINUE END IF NAVT = 0 NAV = 0 DO 350 I = 1, LVA TVAL(I) = 0.0 SVAL(I) = 0.0 VAL0(I) = 0.0 350 CONTINUE MXCUT = 99999 NRECRD(1) = 0 NRECRD(2) = 0 C VBOX(1) = 1.0 END IF C CALL PREPAR (FORMUL) C C ---------------------------------------- Configuration and heading C NREM = IRECRD(1) - NRECRD(1) NSTEP1 = NRECRD(1) + 1 THS1 = 'th' IF (MOD(NSTEP1,10).EQ.1) THS1 = 'st' IF (MOD(NSTEP1,10).EQ.2) THS1 = 'nd' IF (MOD(NSTEP1,10).EQ.3) THS1 = 'rd' THS2 = 'th' IF (MOD(IRECRD(1),10).EQ.1) THS2 = 'st' IF (MOD(IRECRD(1),10).EQ.2) THS2 = 'nd' IF (MOD(IRECRD(1),10).EQ.3) THS2 = 'rd' WRITE (16, 2000) RUNOPT(2),NREM,NSTEP1,THS1,IRECRD(1),THS2,DTIME, * IRECRD(2), * RUNOPT(5),TEMP,DELTMP,NTSTEP,TMPGET,RUNOPT(4), * NRECRD(2),NRECRD(4) IF (RUNOPT(5).EQ.'T NOSE ') WRITE (16,2010) STEMP IF (RUNOPT(6).NE.'P NO-CNTL ') THEN IF (RUNOPT(6).EQ.'P SCALING ') WRITE (16,2020) RUNOPT(6),SPRES IF (RUNOPT(6).EQ.'P ANDERSEN') WRITE (16,2027) RUNOPT(6), * SPRES,(VIRM(LL),LL=1,3) IF (RUNOPT(6).EQ.'P ANDERS-C') WRITE (16,2027) RUNOPT(6), * SPRES,(VIRM(LL),LL=1,3) END IF if (RUNOPT(7).NE.'V '.and.RUNOPT(7).NE.'V CONST ') then if (RUNOPT(7).eq.'V CHANGE ') write (16,2031) runopt(7), * ICAXIS, BTAGET, BCNGR end if C CALL TABLER (1) C C ------------------------------------------ Read RUNOPT(9),...,(27) write (16,2040) lentab = lst IPRDF(1) = 2 IPRDF(2) = 9999 520 READ (15,1000) RUNRUN,PARAM1,PARAM2,PARAM3,PARAM4,PARAM5,PARAM6 IF (RUNRUN.NE.' ') THEN write (6,*) runrun IF (RUNRUN.EQ.'STRUCTURE ' .or. * RUNRUN.EQ.'structure ') then RUNOPT(9) = 'STRUCTURE ' lentab = param1 if (lentab.lt.1) lentab = LST if (lentab.gt.LST) lentab = LST end if IF (RUNRUN.EQ.'NETWORK ' .or. * runrun.eq.'network ') THEN RUNOPT(10) = 'NETWORK ' NATX = 0 IO = PARAM1 IF (IO.GT.0.AND.IO.LE.LEE) THEN NATX = NATX + 1 ATMNET(NATX) = ATOM(IO) END IF IO = PARAM2 IF (IO.GT.0.AND.IO.LE.LEE) THEN NATX = NATX + 1 ATMNET(NATX) = ATOM(IO) END IF WRITE (*,*) 'Network forming cation(s) is(are)', * (i,atmnet(i),i=1,natx) END IF C IF (RUNRUN.EQ.'VELOCITY ' .or. * runrun.eq.'velocity ') THEN RUNOPT(11) = 'VELOCITY ' IRECRD(9) = PARAM1 PVMULT = 50000.0 IF (PARAM2.GT.0) PVMULT = PARAM2 IF (IRECRD(9).LE.0) IRECRD(9) = 1 END IF IF (RUNRUN.EQ.'POSITION ' .or. * runrun.eq.'position ') THEN RUNOPT(11) = 'POSITION ' IRECRD(9) = PARAM1 PVMULT = 9000.0 IF (PARAM2.GT.0) PVMULT = PARAM2 IF (IRECRD(9).LE.1) IRECRD(9) = 1 END IF IF (RUNRUN.EQ.'ENERGY ' .or. * runrun.eq.'energy ') THEN RUNOPT(11) = 'ENERGY ' IRECRD(9) = PARAM1 PVMULT = 1.0E12 IF (PARAM2.GT.0) PVMULT = PARAM2 IF (IRECRD(9).LE.1) IRECRD(9) = 1 END IF IF (RUNRUN.EQ.'POSVELENE ' .or. * runrun.eq.'posvelene ') THEN RUNOPT(11) = 'POSVELENE ' IRECRD(9) = PARAM1 PVMULT = 1.0E12 C IF (PARAM2.GT.0) PVMULT = PARAM2 IF (IRECRD(9).LE.1) IRECRD(9) = 1 END IF IF (RUNRUN.EQ.'QUANTUM ' .or. * runrun.eq.'quantum ') THEN RUNOPT(12) = 'QUANTUM ' CALL QCTABL END IF IF (RUNRUN.EQ.'PCF '.OR.RUNRUN.EQ.'RDF '.or. * runrun.eq.'pcf '.or.runrun.eq.'rdf ') THEN RUNOPT(13) = 'PCF ' IF (PARAM1.GT.0.999) IPRDF(1) = PARAM1 IF (PARAM2.GT.0.5 .AND. PARAM2.LT.20.0) * IPRDF(2) = PARAM2*100 END IF IF (RUNRUN.EQ.'DIPOLE ' .or. * runrun.eq.'dipole ') THEN RUNOPT(14) = 'DIPOLE ' END IF IF (RUNRUN.EQ.'CENTER '.OR.RUNRUN.EQ.'CENTRE '.or. * runrun.eq.'center '.or.runrun.eq.'centre ') THEN RUNOPT(15) = 'CENTER ' END IF IF (RUNRUN.EQ.'CENTERING ' .or. * runrun.eq.'centering ') THEN RUNOPT(15) = 'CENTERING ' iaxcen = PARAM1 END IF IF (RUNRUN.EQ.'NO(MV=0) ') THEN RUNOPT(16) = 'NO(MV=0) ' END IF IF (RUNRUN.EQ.'AM(MV=0) ') THEN RUNOPT(16) = 'AM(MV=0) ' Iamv = param1 Namv = param2 if (Namv.gt.nion(Iamv)) Namv= nion(Iamv) if (Namv.le.0) Namv = nion(Iamv) END IF IF (RUNRUN.EQ.'CRYSTAL ') THEN RUNOPT(17) = 'CRYSTAL ' END IF IF (RUNRUN.EQ.'BINARY ') THEN RUNOPT(18) = 'BINARY ' IF (RUNOPT(2).EQ.'START ') THEN CLOSE (19) OPEN (19, FILE=FLNAME(9), STATUS='UNKNOWN', * ACCESS='SEQUENTIAL', FORM='UNFORMATTED') END IF END IF IF (RUNRUN.EQ.'PRESSURE ') THEN RUNOPT(19) = 'PRESSURE ' OPEN (27, FILE=FLNAME(13), STATUS='UNKNOWN', * ACCESS='SEQUENTIAL', FORM='FORMATTED' ) REWIND 27 END IF IF (RUNRUN.EQ.'ELEC.FIELD') THEN RUNOPT(20) = 'ELEC.FIELD' MEFD = INT(PARAM1) ! Mode of elec.field EFD(1) = DBLE(PARAM2) *1.00D5 ! [EFD]==[V/m] EFD(2) = DBLE(PARAM3) *1.00D5 ! 1 CV/m = 1 J/m EFD(3) = DBLE(PARAM4) *1.00D5 ! = 10^5 erg/cm EFREQ = DBLE(PARAM5) ! Hz c write(6,*) MEFD, EFREQ c write(6,*) EFD(1),EFD(2),EFD(3) END IF if (runrun.eq.'GRAV.FIELD') then runopt(21) = 'GRAV.FIELD' gfd(1) = param1 gfd(2) = param2 gfd(3) = param3 end if if (runrun.eq.'DIATOMIC ') then runopt(23) = 'DIATOMIC ' write (6,*) param1,param2,param3 DINTRA(1) = param2 IATOM2(1) = param3 zmole(1) = param1-zio(iatom2(1))*2.0 MOLstart(1) = param3 MOLend(1) = param3 if (param6.gt.0.0001) then READ (15,1000) RUNRUN,PARAM1,PARAM2,PARAM3,PARAM4, * PARAM5,PARAM6 DINTRA(2) = param2 IATOM2(2) = param3 zmole(2) = param1-zio(iatom2(2))*2.0 MOLstart(2) = param3 MOLend(2) = param3 end if CALL DIATOM write (16,7011) atom(MOLstart(1)),zmole(1), * zio(iatom2(1))*2+zmole(1) 7011 format ('I Diatomic molecule : ',A2, '2 : ', * 'Charge at molecular center is ',F8.4, * ', molecular charge is',f8.4,32x, 'I') if (iatom2(2).gt.0) then write (16,7012) atom(MOLstart(2)),zmole(2), * zio(iatom2(2))*2+zmole(2) 7012 format ('I : ',A2, '2 : ', * 'Charge at molecular center is ',F8.4, * ', molecular charge is',f8.4,32x, 'I') end if end if if (runrun.eq.'CUBE ') then runopt(24) = 'CUBE ' end if if (runrun.eq.'CUBE-F ') then runopt(24) = 'CUBE-F ' end if if (runrun.eq.'CONVEC ') then runopt(25) = 'CONVECTION' fconvc = param1 write (6,*) '[CONVECTION] option is set' end if if (runrun.eq.'MOLECULE ') then runopt(26) = 'MOLECULE ' DINTRA(1) = param1 MOLstart(1) = param2 MOLend(1) = param3 call MOLECULE end if if (runrun.eq.'EXCLUSION ') then runopt(27) = 'EXCLUSION ' READ (15,1000) RUNRUN,PARAM1,PARAM2,PARAM3,PARAM4, * PARAM5,PARAM6 if (RUNRUN.eq.'COLUMN '.or. * RUNRUN.eq.'SLUB ' ) then iextype = 1 if (RUNRUN.eq.'SLUB ') iextype = 2 iaex = param1 REXCL = param2 Fexcl = param3 c write (6,*) iextype, iaex,rexcl,fexcl end if if (RUNRUN.eq.'CUBE ') then iextype = 3 rexcl = param1 Fexcl = param2 end if if (RUNRUN.eq.'SPHERE ') then iextype = 4 end if if (RUNRUN.eq.'HONEYCOMB ') then iextype = 5 iaex = param1 rexcl = param2 fexcl = param3 end if if (Fexcl.lt.1.0E-9) Fexcl = 1.0E-5 end if if (runrun.eq.'WALL ') then runopt(28) = 'WALL ' WALLa = param1 WALLb = param2 end if if (runrun.eq.'POLYATOMS ') then runopt(29) = 'POLYATOMS ' DINTRA(1) = param1 MOLstart(1) = param2 MOLend(1) = param3 call MOLECULE end if if (runrun.eq.'REMOVE ') then runopt(30) = 'REMOVE ' RMZL = param1 RMZH = param2 RMVZ = param3 end if if (runrun.eq.'T GRAD ') then runopt(30) = 'T GRAD ' IAXTDR = param1 T000 = param2 T050 = param3 end if GOTO 520 END IF WRITE (16,2030) (I,RUNOPT(I),I=1,32) C ---------------------------------------------------- Check P and V CALL CHECKP (DTMO) C ------------------------------------------------------ file09p.dat IF (RUNOPT(2).EQ.'START ') THEN IF (RUNOP1.EQ.'MD..') THEN IF (TITLE(1).NE.'BENC' .OR. * TITLE(2).NE. 'HMAR' ) THEN NRECRD(4) = 1 IF (RUNOPT(18).EQ.'BINARY ') THEN WRITE (19) NRECRD(4), 0, BOX(1), 0.0, 0.0, * 0.0, BOX(2), 0.0, 0.0, 0.0, BOX(3) WRITE (19) ((SNGL(P(J,I)),J=1,3),I=1,NTION) ELSE DO 450 I = 1, NTION DO 450 J = 1, 3 IPV(J,I) = P(J,I) * 9000.0 450 CONTINUE DUMMY = ' ' WRITE (19,9001) NRECRD(4), 0, BOX(1), * 0.0, 0.0, 0.0, BOX(2), * 0.0, 0.0, 0.0, BOX(3) WRITE (19,9002) ((IPV(J,I),J=1,3),I=1,NTION) END IF END IF END IF END IF C ----------------------------------------------------- file09PV.dat IF (RUNOPT(11).NE.' ') THEN IF (RUNOPT(18).EQ.'BINARY ') THEN OPEN (28, FILE=FLNAME(12), STATUS='UNKNOWN', * ACCESS='SEQUENTIAL', FORM='UNFORMATTED' ) ELSE OPEN (28, FILE=FLNAME(12), STATUS='UNKNOWN', * ACCESS='SEQUENTIAL', FORM='FORMATTED' ) END IF REWIND 28 NRECRD(9) = 1 IF (RUNOPT(11).EQ.'VELOCITY ') THEN IF (RUNOPT(18).EQ.'BINARY ') THEN DO 550 I = 1, NTION DO 550 J = 1, 3 VV(J,I) = V(J,I) / DTIME 550 CONTINUE WRITE (28) NRECRD(1),IRECRD(9) WRITE (28) ((VV(J,I),J=1,3),I=1,NTION) ELSE DO 560 I = 1, NTION DO 560 J = 1, 3 IPV(J,I)=V(J,I)*PVMULT*1E-15/DTIME +5000.0 560 CONTINUE WRITE (28,9001) NRECRD(1),IRECRD(9) WRITE (28,9002) ((IPV(J,I),J=1,3),I=1,NTION) END IF END IF IF (RUNOPT(11).EQ.'POSITION ') THEN IF (RUNOPT(18).EQ.'BINARY ') THEN WRITE (28) NRECRD(1),IRECRD(9), * BOX(1), 0.0, 0.0, 0.0, BOX(2), * 0.0, 0.0, 0.0, BOX(3) WRITE (28) ((SNGL(P(J,I)),J=1,3),I=1,NTION) ELSE DO 580 I = 1, NTION DO 580 J = 1, 3 IPV(J,I) = P(J,I) * PVMULT 580 CONTINUE WRITE (28,9001) NRECRD(1),IRECRD(9), * BOX(1), 0.0, 0.0, 0.0, BOX(2), * 0.0, 0.0, 0.0, BOX(3) WRITE (28,9002) ((IPV(J,I),J=1,3),I=1,NTION) END IF END IF 9001 FORMAT (I7,i3,9F7.3) 9002 FORMAT (18I4) END IF C ------------------------------------------------------------------ IF (NREM.LE.0) GO TO 2222 CALL TITLET (0, 1) RETURN C 2222 WRITE (*,2233) RUNOPT(2) 2233 FORMAT ('>>>>> The number of steps to be calculated is less', * ' than one >>>>>' / * '>>>>> Mode=', A9, ' Please increase the number ', * 'of steps >>>>>' ) STOP C 1000 FORMAT (A10, 6F10.5) 1001 FORMAT (A10, 15A4) 1300 FORMAT (I1,A1,A2, F6.0,6F10.0) 2000 FORMAT ('I [ ',A10,' ] ',I7,' steps-run from',I7,'-',A2, * ' to ',I7,'-',A2,' step with time step of', * 1PE9.2,' sec. RDF''s at every', I7,' step I' / * 'I [ ',A10,' ] Temperature=',0PF7.1,' K changed ', * 'with a rate of',F6.1,' K per ', I3, ' steps until', * F7.1,' K (',A8,' : ',I5,' : ',I4,') I' ) 2010 FORMAT ('I',18X,'"Mass" of Nose''s thermostat is ',E12.4, * ' g.cm2',63X,'I' ) 2020 FORMAT ('I [ ',A10,' ] Pressure is controlled at ',3F9.4, * 'GPa using forced scaling of cell dimensions.',14X, * 'I') 2027 FORMAT ('I [ ',A10,' ] Pressure is controlled at ',3F9.4, * ' GPa by Andersen''s mass ',3(1X,G9.2E3), * ' g I') 2031 format ('I [ ',A10,' ] Cell size of axis ',i1, ' is canged to ', * F10.5, ' Angstroms by rate of ',F8.5, * ' Angstroms/step',24x,'I') 2030 format ('I',130('-'),'I' / * 'I [Options] ',8(I3,':',A10),' I' / * 'I ',8(I3,':',A10),' I' / * 'I ',8(I3,':',A10),' I' / * 'I ',8(I3,':',A10),' I' ) 2040 format ('I',130('-'),'I' ) END C C C ========== C============================================================== MOLECULE SUBROUTINE MOLECULE PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C ======================================recognize diatomic molecules COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /CARTES/ H(3,3),HINV(3,3),FTOQ(3,3),RBOX(6), * G(3,3),GINV(3,3),TRANSX(8),TRANSY(8),TRANSZ(8) CT * ,Q(3,LNI),Q0(3,LNI) REAL *8 H,HINV,G,GINV,FTOQ,RBOX,TRANSX,TRANSY,TRANSZ COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME c COMMON /MOLECU/ ZMOLE(2), DMOLE(4,LNI), DINTRA(2), * NDMOLE, IDMOLE(3,LNI), IATOM2(2), MOLstart(2), * NMOLE, IMOLE(38,LNI), MMOLE(LNI), MOLend(2) real *8 zmole,dmole real *8 rx, ry, rz, dx, dy, dz integer mi(lni), ndistr(38) c cut2 = dintra(1)**2 do 10 I = 1, ntion mi(i) = 0 10 continue do 20 n = 1, 38 ndistr(n) = 0 20 continue nnn = 1 ! No. of molecules imole(1,nnn) = ions(1,MOLstart(1)) mi(ions(1,MOLstart(1))) = 1 mmole(nnn) = 1 ! No. of atoms in the molecule C------------------------------------------- calc distance between atoms do 590 io = MOLstart(1), MOLend(1) do 510 i = ions(1,io), ions(2,io) if (mi(i).gt.0) go to 510 c do 500 n = 1, nnn do 400 k = 1, mmole(n) j=imole(k,n) if (i.eq.j) go to 510 RX = P(1,i) - P(1,j) RY = P(2,i) - P(2,j) RZ = P(3,i) - P(3,j) if (RX.lt.-0.5) RX = RX + 1.0 if (RX.gt. 0.5) RX = RX - 1.0 if (RY.lt.-0.5) RY = RY + 1.0 if (RY.gt. 0.5) RY = RY - 1.0 if (RZ.lt.-0.5) RZ = RZ + 1.0 if (RZ.gt. 0.5) RZ = RZ - 1.0 c --------- delete these if-statements for triclinic IF (ABS(RX).GT.0.5) RX = RX - SIGN(1.0D0,RX) IF (ABS(RY).GT.0.5) RY = RY - SIGN(1.0D0,RY) IF (ABS(RZ).GT.0.5) RZ = RZ - SIGN(1.0D0,RZ) c DX = H(1,1)*RX + H(1,2)*RY + H(1,3)*RZ c DY = H(2,1)*RX + H(2,2)*RY + H(2,3)*RZ c DZ = H(3,1)*RX + H(3,2)*RY + H(3,3)*RZ DX = RX * BOX(1) DY = RY * BOX(2) DZ = RZ * BOX(3) RIJ2 = DX*DX + DY*DY + DZ*DZ IF (RIJ2.gt.CUT2) GO TO 400 mmole(n) = mmole(n) + 1 IMOLE(mmole(n),n) = i mi(i) = 1 go to 510 400 CONTINUE c 500 continue nnn=nnn+1 imole(1,nnn) = i mi(i)=1 mmole(nnn) = 1 510 CONTINUE 590 continue c c write (6,*) (mmole(n),n=1,nnn) c do 660 n2=2, nnn mm2=mmole(n2) if (mm2.le.0) go to 660 do 650 n1 = 1, n2-1 mm1=mmole(n1) mm2=mmole(n2) if (mm1.le.0) go to 650 do 630 m1=1, mm1 do 640 m2=1, mm2 i=imole(m1,n1) j=imole(m2,n2) RX = P(1,i) - P(1,j) RY = P(2,i) - P(2,j) RZ = P(3,i) - P(3,j) if (RX.lt.-0.5) RX = RX + 1.0 if (RX.gt. 0.5) RX = RX - 1.0 if (RY.lt.-0.5) RY = RY + 1.0 if (RY.gt. 0.5) RY = RY - 1.0 if (RZ.lt.-0.5) RZ = RZ + 1.0 if (RZ.gt. 0.5) RZ = RZ - 1.0 c --------- delete these if-statements for triclinic IF (ABS(RX).GT.0.5) RX = RX - SIGN(1.0D0,RX) IF (ABS(RY).GT.0.5) RY = RY - SIGN(1.0D0,RY) IF (ABS(RZ).GT.0.5) RZ = RZ - SIGN(1.0D0,RZ) c DX = H(1,1)*RX + H(1,2)*RY + H(1,3)*RZ c DY = H(2,1)*RX + H(2,2)*RY + H(2,3)*RZ c DZ = H(3,1)*RX + H(3,2)*RY + H(3,3)*RZ DX = RX * BOX(1) DY = RY * BOX(2) DZ = RZ * BOX(3) RIJ2 = DX*DX + DY*DY + DZ*DZ IF (RIJ2.le.CUT2) then mmm1=mmole(n1) do m=1, mm2 imole(mmm1+m,n1)=imole(m,n2) mmole(n1)=mmm1+mm2 mmole(n2)=0 end do go to 660 end if 640 continue 630 continue 650 continue 660 continue c c nmole=0 do n=1, nnn na = mmole(n) if (na.gt.38) na=38 if (na.gt.0) then ndistr(na)=ndistr(na)+1 nmole=nmole+1 mmole(nmole)=mmole(n) do i=1, mmole(n) imole(i,nmole)=imole(i,n) end do end if end do c write (6,*) (mmole(n),n=1,nmole) c write (6,1001) nmole 1001 format (' Total number of molecules is',I5) c write (6,1002) (n,n=1,30), (ndistr(n),n=1,32) write (6,1003) (ndistr(n),n,n=1,32) 1002 format ('N.A',15I5 / 3X,15I5 / 'N.M',15I5 / 3x,15I5) 1003 format (8(I5,'[',I2,'] ')) c RETURN END C C C ======== C================================================================ DIATOM SUBROUTINE DIATOM PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C ======================================recognize diatomic molecules COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /CARTES/ H(3,3),HINV(3,3),FTOQ(3,3),RBOX(6), * G(3,3),GINV(3,3),TRANSX(8),TRANSY(8),TRANSZ(8) CT * ,Q(3,LNI),Q0(3,LNI) REAL *8 H,HINV,G,GINV,FTOQ,RBOX,TRANSX,TRANSY,TRANSZ COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME c COMMON /MOLECU/ ZMOLE(2), DMOLE(4,LNI), DINTRA(2), * NDMOLE, IDMOLE(3,LNI), IATOM2(2), MOLstart(2), * NMOLE, IMOLE(38,LNI), MMOLE(LNI), MOLend(2) real *8 zmole,dmole real *8 pix,piy,piz, pjx,pjy,pjz, rx,ry,rz, dx,dy,dz, * pjx0,pjy0,pjz0, rij2 c C---------------------------------------------calc distance of atoms nnn = 0 do 900 iii = 1, 2 cut2 = dintra(iii)**2 io = iatom2(iii) if (io.le.0 .or. io.gt.ncompo) go to 900 i1 = ions(1,io) i2 = ions(2,io) DO 810 I=i1, i2-1 pix = p(1,i) piy = p(2,i) piz = p(3,i) do 800 J=i+1,i2 pjx0 = p(1,j) pjy0 = p(2,j) pjz0 = p(3,j) if (pjx0.lt.pix) pjx0 = pjx0 + 1.0 if (pjy0.lt.piy) pjy0 = pjy0 + 1.0 if (pjz0.lt.piz) pjz0 = pjz0 + 1.0 DO 250 K = 1, 8 pjx = pjx0 - transx(k) pjy = pjy0 - transy(k) pjz = pjz0 - transz(k) RX = PIX - PjX RY = PIY - PjY RZ = PIZ - PjZ c - - - - - delete these if-statements for triclinic c IF (ABS(RX).GT.0.5) RX = RX - SIGN(1.0D0,RX) c IF (ABS(RY).GT.0.5) RY = RY - SIGN(1.0D0,RY) c IF (ABS(RZ).GT.0.5) RZ = RZ - SIGN(1.0D0,RZ) c DX = H(1,1)*RX + H(1,2)*RY + H(1,3)*RZ c DY = H(2,1)*RX + H(2,2)*RY + H(2,3)*RZ c DZ = H(3,1)*RX + H(3,2)*RY + H(3,3)*RZ DX = RX * BOX(1) DY = RY * BOX(2) DZ = RZ * BOX(3) RIJ2 = DX*DX + DY*DY + DZ*DZ IF (RIJ2.LE.CUT2) GO TO 255 250 CONTINUE go to 800 C ----------------------------------Kumiawase of diatomic 255 nnn = nnn +1 IDMOLE(1,nnn) = I IDMOLE(2,nnn) = J IDmole(3,nnn) = iii DMOLE(1,nnn) = DX DMOLE(2,nnn) = Dy DMOLE(3,nnn) = DZ DMOLE(4,nnn) = SQRT(RIJ2) C -----------------------------------P of center of mass Pix=(Pix+Pjx)/2. Piy=(Piy+Pjy)/2. Piz=(Piz+Pjz)/2. if (pix.lt.0.0) pix = pix + 1.0 if (pix.gt.1.0) pix = pix - 1.0 if (piy.lt.0.0) piy = piy + 1.0 if (piy.gt.1.0) piy = piy - 1.0 if (piz.lt.0.0) piz = piz + 1.0 if (piz.gt.1.0) piz = piz - 1.0 p(1,ntion+nnn) = pix p(2,ntion+nnn) = piy p(3,ntion+nnn) = piz C C WRITE(*,*) nnn,IDMOLE(1,nnn),IDMOLE(2,nnn),pix,piy,piz C 800 CONTINUE 810 continue 900 CONTINUE ndmole = nnn RETURN END C C C ======== C================================================================ PREPAR SUBROUTINE PREPAR (FORMUL) PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C C ----------------------------------- Preparing some variables, etc. C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES(3),PPXYZ(7),FJMOL, * T000,T050, IAXTGR, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME COMMON /PARAMT/ AIO(LEM),BIO(LEM),CIO(LEM),DIO(LEM),ZIO(LEM), * AIJ(LEF),BIJ(LEF),CIJ(LEF),DIJ(LEF),D4IJ(LEF), * PLIJ(LEF),RSWTCH(LEF),ZIJ(LEF), D7IJ(LEF), * ECORR,VCORR, WIO(LEM), TWEGHT, AKFI(LEM), * ANG3BP(L3P), R3BLIM(2,L3P), * FK3BP(L3P), R3BGRD(2,L3P), R3lim(2,l3p),r3limax, * I3BP(3,L3P), N3BP COMMON /TABLES/ F1(LSR,LEE),E1(LSR,LEE),F0(LTB),E0(LTB) REAL *8 F1,E1,F0,E0 COMMON /VALUES/ TVAL(LVA),TVALL(LVA),VALMAX(LVA),VAL0(LVA), * SVAL(LVA),SVALL(LVA),VALMIN(LVA), * VAL(LVA),AVA(LVA,L50), NAV,NAVT REAL *8 TVAL,SVAL,TVALL,SVALL,VALMAX,VALMIN,VAL0,VAL,AVA COMMON /RADIAL/ NRDF(LTB,LEE),IPRDF(2) INTEGER *4 NRDF COMMON /GEOMET/ DTO(2),AVTHT(12),MBR(8,8,2),NRG(9,2),ITBR(121,12), * RTO(2),SVTHT(12),NBR(8,8,2),MEB(9,2), NTT(121,12), * NTO(2),NVTHT(12),ANGL(3,12),TTAB(LST), NTBL, * ANCN(7,2) COMMON /CONSTS/ PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL REAL *8 PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL C NELM = 0 TWEGHT = 0.0D0 DO 260 IO = 1, NCOMPO IONS(1,IO) = NELM + 1 NELM = NELM + NION(IO) IONS(2,IO) = NELM NIOND(IO) = 0 DO 250 J = IONS(1,IO), IONS(2,IO) IF (IOND(J).NE.0) NIOND(IO) = NIOND(IO) + 1 250 CONTINUE TWEGHT = TWEGHT + WIO(IO) * REAL(NIOND(IO)) 260 CONTINUE NFORML = NION(2) IF (NFORML.EQ.0) NFORML = NION(3) IF (FORMUL.GT.0.0) NFORML = NION(1) / FORMUL FJMOL = ANA / 1.0D10 / REAL(NFORML) IF (NELM.GT.NTION) GO TO 4444 IF (NELM.LT.NTION) WRITE (*,1004) NELM,NTION NTION = NELM C DO 500 I = 1, LVA VALMAX (I) = -9.9D19 VALMIN (I) = 9.9D19 500 CONTINUE C TPRE = TEMP RETURN C 4444 WRITE (*,4455) 4455 FORMAT (' ***** THE NUMBER OF PARTICLES IN FILE05 IS MORE THAN ', * 'THAT IN FILE07 *****') STOP C 1004 FORMAT (' ******* Warnning ***** NTION(new)=',I5,' (old)=', * I5,7('*')) 1111 FORMAT (15A4) END C C C ======== C================================================================ CHECKP SUBROUTINE CHECKP (DTMO) PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C C ----------------------------------- Preparing some variables, etc. C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES(3),PPXYZ(7),FJMOL, * T000,T050, IAXTGR, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME COMMON /PARAMT/ AIO(LEM),BIO(LEM),CIO(LEM),DIO(LEM),ZIO(LEM), * AIJ(LEF),BIJ(LEF),CIJ(LEF),DIJ(LEF),D4IJ(LEF), * PLIJ(LEF),RSWTCH(LEF),ZIJ(LEF), D7IJ(LEF), * ECORR,VCORR, WIO(LEM), TWEGHT, AKFI(LEM), * ANG3BP(L3P), R3BLIM(2,L3P), * FK3BP(L3P), R3BGRD(2,L3P), R3lim(2,l3p),r3limax, * I3BP(3,L3P), N3BP COMMON /CONSTS/ PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL REAL *8 PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL C REAL *8 RL ,TT,FV,DL,CENTER C C ----------------------- Check and correct velocity and momentum FV = 1.0D0 TT = TEMP IF (TT.LT.0.001) TT = 0.001 IF ((TMPGET-TEMP)*DELTMP.LT.0.0) TEMP = TMPGET FV = SQRT(TEMP/TT) * (DTIME/DTMO) DO 370 J = 1, 3 DL = 0.0D0 DO 330 IO = 1, NCOMPO RL = 0.0D0 IF (NION(IO).GT.0) THEN I1 = IONS(1,IO) I2 = IONS(2,IO) DO 310 I = I1, I2 IF (IOND(I).NE.0) RL = RL + V(J,I) 310 CONTINUE END IF DL = DL + RL * WIO(IO) 330 CONTINUE DL = DL / TWEGHT IF (RUNOPT(16).EQ.'NO(MV=0) ') THEN DL = 0.0D0 END IF DO 350 I = 1, NTION IF (P(J,I).LT.0.0D0) P(J,I) = P(J,I) + 1.0D0 IF (P(J,I).GE.1.0D0) P(J,I) = P(J,I) - 1.0D0 IF (IOND(I).NE.0) V(J,I) = (V(J,I) - DL) * FV IF (IOND(I).EQ.0) V(J,I) = 0.0 IF (P(J,I)-P0(J,I).GT. 0.5) P0(J,I) = P0(J,I) + 1.0 IF (P(J,I)-P0(J,I).LT.-0.5) P0(J,I) = P0(J,I) - 1.0 350 CONTINUE IF (RUNOPT(15).EQ.'CENTER ') THEN CENTER = 0.0D0 DO 360 I = 1, NTION CENTER = CENTER + P(J,I) 360 CONTINUE CENTER = CENTER / NTION - 0.5D0 DO 362 I = 1, NTION P(J,I) = P(J,I) - CENTER P0(J,I) = P0(J,I) - CENTER 362 CONTINUE END IF 370 CONTINUE C RETURN END C C C ======== C================================================================ TABLER SUBROUTINE TABLER (IPR) PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C C --------------------------------------------- Heading of MD output C Preparing tables for force and energy calculations C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES(3),PPXYZ(7),FJMOL, * T000,T050, IAXTGR, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /VECTOR/ FNV(LNV),UNV(LNV),PNV(6,LNV),ZIA(LEM),UCSELF, * ALPHA,UCSLFI(LEM), MODE, NVN, NVEC(3,LNV) REAL *8 FNV,UNV,PNV,ZIA,UCSELF,ALPHA,UCSLFI COMMON /PARAMT/ AIO(LEM),BIO(LEM),CIO(LEM),DIO(LEM),ZIO(LEM), * AIJ(LEF),BIJ(LEF),CIJ(LEF),DIJ(LEF),D4IJ(LEF), * PLIJ(LEF),RSWTCH(LEF),ZIJ(LEF), D7IJ(LEF), * ECORR,VCORR, WIO(LEM), TWEGHT, AKFI(LEM), * ANG3BP(L3P), R3BLIM(2,L3P), * FK3BP(L3P), R3BGRD(2,L3P), R3lim(2,l3p),r3limax, * I3BP(3,L3P), N3BP COMMON /TABLES/ F1(LSR,LEE),E1(LSR,LEE),F0(LTB),E0(LTB) REAL *8 F1,E1,F0,E0 COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME COMMON /CONSTS/ PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL REAL *8 PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL C CHARACTER *63 LOGO1(18), LOGO2(18), LOGO3(12) DATA LOGO1 / *' ******* ************************** ', *' **** *********** ******** ', *' ***** ********* ******** ', *' ****** ********** ********* ', *' ******* *********** *********', *' **** *** ************ *********', *' *** *** *** ********* *********', *' *** *** *** ********* *********', *' *** *** *** ********* *********', *' *** *** *** ********* ******** ', *' *** ******* ********* ******* ', *' **** ***** ********* ******* ', *' ***** *** ********* ******* ', *' ***** * ********* ******* ', *' ******* ********* ****** ', *' ******** *********** ****** ', *'*********** ************************ R', *' '/ DATA LOGO2 / *'************ ************************* ', *' ********* ************ ******* ', *' ******** *********** ******* ', *' ******* *** ******** ******** ', *' ****** *** ******** ******** ', *' ****** *** ******** ********', *' ****** *** ******** ********', *' ******** ******** ********', *' ****** ******** ********', *' ******** ******** ******* ', *' *** ****** ******** ******* ', *' *** ****** ******** ******* ', *' *** ****** ******** ******* ', *' *** ****** ******** ****** ', *' **** ****** ******** ****** ', *' ****** ******* ********** ****** ', *'********** *************************** R', *' '/ DATA LOGO3 / *'Ms-Fortran-PowerStation Ver.4.0 Version ', *'386DX+FPU/486DX/Pentium + NDP-FORTRAN/xxx Version ', *'LUNA-88K (88100+88200) + f77 Version ', *'Transputer (T805) + Parallel fortran (3L) Version ', *'HP 9000 Series (PA-RISC) + f77 Version ', *'IBM-AIX-FORT Version ', *'F77 on Sony NEWS-WS Version ', *'FTN compilar on DN10000 Version ', *'Hitachi Super Computer (S820-80) Version ', *'F77 on CRAY Super Computer Version ', *'DEC Fortran for Windows NT Version ', *' Version '/ c if (FLNAME(3).eq.'Ms-Fortran ') logo3(1) = logo3(1) if (FLNAME(3).eq.'NDP-FORTRAN386') logo3(1) = logo3(2) IF (FLNAME(3).EQ.'LUNA88K ') LOGO3(1) = LOGO3(3) IF (FLNAME(3).EQ.'PARALLEL-F77 ') LOGO3(1) = LOGO3(4) IF (FLNAME(3).EQ.'HP-9000 ') LOGO3(1) = LOGO3(5) if (FLNAME(3).eq.'IBM-AIX-FORT ') logo3(1) = logo3(6) if (FLNAME(3).eq.'NEWS-F77 ') logo3(1) = logo3(7) if (FLNAME(3).eq.'DN10000 ') logo3(1) = logo3(8) if (FLNAME(3).eq.'S820-80 ') logo3(1) = logo3(9) if (FLNAME(3).eq.'CRAY-F77 ') logo3(1) = logo3(10) if (FLNAME(3).eq.'DEC Fortran ') logo3(1) = logo3(11) if (FLNAME(3).eq.'Dummy ') logo3(1) = logo3(12) C IF (RUNOPT(17) .EQ.'CRYSTAL ') THEN DO 10 I = 1, 18 LOGO1(I) = LOGO2(I) 10 CONTINUE END IF C CALL TMATRX C IF (RUNOPT(8).NE.'METAL ') CALL COULMB C C -------------------------------------------------------- LOGO mark IF (IPR.EQ.1) THEN WRITE (16,5000) (REAL(NION(I))/REAL(NFORML),ATOM(I),I=1,LEM) WRITE (16,5001) BOX(1),BOX(4), * BOX(2),BOX(5), LOGO1(1), * BOX(3),BOX(6), LOGO1(2), LOGO1(3), * DENSTY, LOGO1(4), LOGO1(5) WRITE (16,5002) RUNOPT(8),MODE,NVN, LOGO1(6), * ALPHA,RCUT(1),LOGO1(7), * LOGO1(8), LOGO1(9) 5000 FORMAT('I--', 128('-'), 'I' / * 'I Formula = ',10(F6.3,A2,1X), 26X,' I' / * 'I--', 126('-'), '--I' ) 5001 FORMAT('I Basic cell : A=',F10.5,' A cos(alpha)=',F9.5, * 10X,'I ',63X, ' I'/ * 'I B=',F10.5,' A cos(beta )=',F9.5, * 10X,'I ',A63, ' I'/ * 'I C=',F10.5,' A cos(gamma)=',F9.5, * 10X,'I ',A63, ' I'/ * 'I--',60('-'),'I ', A63, ' I' / * 'I Density : ',F12.7,' g/cm3',29X,'I ',A63, * ' I' / * 'I--',60('-'),'I ',A63, ' I' ) 5002 FORMAT('I ',A8,' I Mode =',I3, 13X, 'No.of Nv=',I5, * 9X,'I ',A63,' I' / * 'I ',8X,' I Alpha=',F6.3,' A-1 Rcut(L) =', * F7.3,' A', 5X,'I ', A63, ' I' / * 'I--',60('-'),'I ', A63,' I' / * 'I Atom No Z W A B', * 7X,'C D I ',A63,' I' ) C DO 110 I = 1, 8 WRITE (16,5005) I, ATOM(I), NION(I), ZIO(I), WIO(I), * AIO(I), BIO(I), CIO(I), DIO(I), * LOGO1(I+9) 5005 FORMAT('I', I3, 2X, A3, I6, F8.3, F7.2, F8.4, 3F8.3, * ' I ',A63,' I' ) 110 CONTINUE I = 9 WRITE (16,5006) I, ATOM(I), NION(I), ZIO(I), WIO(I), * AIO(I), BIO(I), CIO(I), DIO(I), * LOGO3(1),FLNAME(2) I = 10 WRITE (16,5006) I, ATOM(I), NION(I), ZIO(I), WIO(I), * AIO(I), BIO(I), CIO(I), DIO(I), * ' ', ' ' 5006 FORMAT('I', I3, 2X, A3, I6, F8.3, F7.2, F8.4, 3F8.3, * ' I ',A50,A13,' I' ) END IF C C ------------------------------------------------------ Short range IF (RUNOPT(8).EQ.'METAL ') CALL METALP (IPR) IF (IPR.EQ.1) THEN r3limax = 0.0 IF (RUNOPT(8).EQ.' ') CALL BUSING IF (RUNOPT(8).EQ.'BUSING ') CALL BUSING IF (RUNOPT(8).EQ.'STSUNE ') CALL BUSING IF (RUNOPT(8).EQ.'MORSE ') CALL MORSEP IF (RUNOPT(8).EQ.'MORSE-AT ') CALL MORSEP if (runopt(8).eq.'MORSEQ ') CALL MORSEQ IF (RUNOPT(8).EQ.'BMH-EXP ') CALL BMHEXP IF (RUNOPT(8).EQ.'BMH-EXP* ') CALL BMHEXP IF (RUNOPT(8).EQ.'BMH-EXPQ ') CALL BMHEXPQ IF (RUNOPT(8).EQ.'BELONO ') CALL MORSEP IF (RUNOPT(8).EQ.'TOSIFUMI ') CALL TOSIFU IF (RUNOPT(8).EQ.'WOODCOCK ') CALL ANGELP IF (RUNOPT(8).EQ.'PAULING ') CALL ANGELP IF (RUNOPT(8).EQ.'L-J ') CALL LJMODL IF (RUNOPT(8).EQ.'PAIR-P ') CALL PAIRP C IF (RUNOPT(3).EQ.'DETAIL ') THEN DO 200 I = 10, 300, 10 RIJ = I * 0.01 WRITE (16,6666) RIJ, E0(I)*1E8, * (E1(I,J)*1E8,J=1,NPAIR) 200 CONTINUE WRITE (16,6666) DO 210 I = 10, 300, 10 RIJ = I * 0.01 WRITE (16,6666) RIJ,F0(I),(F1(I,J),J=1,NPAIR) 210 CONTINUE WRITE (16,6666) DO 220 I = 10, 300, 10 RIJ = I * 0.01 WRITE (16,6666) RIJ,F0(I), * (F1(I,J)+zij(j)*F0(i),J=1,NPAIR) 220 CONTINUE 6666 FORMAT (2X,F5.2,1X,F10.6,1X,10F11.7) END IF END IF C ECORR = 0.0 VCORR = 0.0 IF (RUNOPT(8).EQ.' ' .OR. RUNOPT(8).EQ.'BUSING ' .OR. * RUNOPT(8).EQ.'STSUNE ' .OR. RUNOPT(8).EQ.'MORSE ' .OR. * RUNOPT(8).EQ.'MORSE-AT ' .OR. RUNOPT(8).EQ.'BMH-EXP ' .OR. * runopt(8).eq.'MORSEQ ' .or. RUNOPT(8).EQ.'BMH-EXP* ' .OR. * runopt(8).eq.'BMH-EXPQ ' .or. * RUNOPT(8).EQ.'BELONO ' .OR. RUNOPT(8).EQ.'PAIR-P ' .OR. * RUNOPT(8).EQ.'TOSIFUMI ' .OR. RUNOPT(8).EQ.'WOODCOCK ' .OR. * RUNOPT(8).EQ.'PAULING ' .OR. RUNOPT(8).EQ.'L-J ') THEN CALL VWCORR END IF RETURN END C C C ======== C================================================================ TMATRX SUBROUTINE TMATRX PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C COMMON /PARAMT/ AIO(LEM),BIO(LEM),CIO(LEM),DIO(LEM),ZIO(LEM), * AIJ(LEF),BIJ(LEF),CIJ(LEF),DIJ(LEF),D4IJ(LEF), * PLIJ(LEF),RSWTCH(LEF),ZIJ(LEF), D7IJ(LEF), * ECORR,VCORR, WIO(LEM), TWEGHT, AKFI(LEM), * ANG3BP(L3P), R3BLIM(2,L3P), * FK3BP(L3P), R3BGRD(2,L3P), R3lim(2,l3p),r3limax, * I3BP(3,L3P), N3BP COMMON /CONSTS/ PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL REAL *8 PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /CARTES/ H(3,3),HINV(3,3),FTOQ(3,3),RBOX(6), * G(3,3),GINV(3,3),TRANSX(8),TRANSY(8),TRANSZ(8) CT * ,Q(3,LNI),Q0(3,LNI) REAL *8 H,HINV,G,GINV,FTOQ,RBOX,TRANSX,TRANSY,TRANSZ C REAL *8 SINA(3), COSA(3), DET, GG C ---------------------------- cos and sin of alpha, beta, and gamma DO 20 I = 1, 3 COSA(I) = BOX(I+3) IF (BOX(I+3).GT.1.0) THEN COSA(I) = COS(BOX(I+3)*PI/180.0D0) BOX(I+3) = COSA(I) END IF SINA(I) = SQRT(1.0D0 - COSA(I)**2) 20 CONTINUE C C ------------------ Transformation matrix from crystal to Cartesian C H(1,3) = 0.D0 H(2,3) = 0.D0 H(3,3) = BOX(3) H(1,2) = 0.0D0 H(2,2) = BOX(2)*SINA(1) H(3,2) = BOX(2)*COSA(1) H(3,1) = BOX(1)*COSA(2) H(2,1) = BOX(1)*COSA(3)*SINA(1) H(1,1) = BOX(1)*SQRT(1-COSA(2)**2-(COSA(3)*SINA(1))**2) VOL = H(3,1)*(H(1,2)*H(2,3) - H(2,2)*H(1,3)) - * H(2,1)*(H(1,2)*H(3,3) - H(3,2)*H(1,3)) + * H(1,1)*(H(2,2)*H(3,3) - H(3,2)*H(2,3)) IF (VOL.LE.0.0D0) THEN H(1,1) = - H(1,1) H(2,1) = - H(2,1) H(3,1) = - H(3,1) VOL = - VOL END IF DENSTY = TWEGHT / (ANA * VOL * 1.0D-24) C C WRITE (*,*) H(1,1), H(2,1), H(3,1) C WRITE (*,*) H(1,2), H(2,2), H(3,2) C WRITE (*,*) H(1,3), H(2,3), H(3,3) C WRITE (*,*) VOL C C ------------------ Transformation matrix from Cartesian to crystal C CALL INVERS (H, DET, HINV) C C WRITE (*,*) HINV(1,1), HINV(2,1), HINV(3,1) C WRITE (*,*) HINV(1,2), HINV(2,2), HINV(3,2) C WRITE (*,*) HINV(1,3), HINV(2,3), HINV(3,3) C C ---------------------------------------------------- Metric tensor DO 80 I = 1, 3 DO 80 J = 1, 3 GG = 0.0D0 DO 70 K = 1, 3 GG = GG + H(K,J) * H(K,I) 70 CONTINUE G(J,I) = GG 80 CONTINUE CALL INVERS (G, DET, GINV) C -------------------------- Trans. of reciprocal force to cartesian C FTOQ(1,1) = H(1,1) / BOX(1) FTOQ(2,1) = H(2,1) / BOX(1) FTOQ(3,1) = H(3,1) / BOX(1) FTOQ(1,2) = H(1,2) / BOX(2) FTOQ(2,2) = H(2,2) / BOX(2) FTOQ(2,3) = H(3,2) / BOX(2) FTOQ(1,2) = H(1,3) / BOX(3) FTOQ(2,2) = H(2,3) / BOX(3) FTOQ(2,3) = H(3,3) / BOX(3) C C --------------------------------------- Reciprocal cell parameters RBOX(1) = BOX(2)*BOX(3)*SINA(1) / VOL RBOX(2) = BOX(1)*BOX(3)*SINA(2) / VOL RBOX(3) = BOX(1)*BOX(2)*SINA(3) / VOL RBOX(4) = (COSA(2)*COSA(3)-COSA(1)) / (SINA(2)*SINA(3)) RBOX(5) = (COSA(1)*COSA(3)-COSA(2)) / (SINA(1)*SINA(3)) RBOX(6) = (COSA(1)*COSA(2)-COSA(3)) / (SINA(1)*SINA(2)) C --------------------------------------- IF (RCUT(1).LT.0.01) RCUT(1) = 15.0 IF (RCUT(1).GT.1.0/RBOX(1)/2) RCUT(1) = 1.0/RBOX(1)/2 IF (RCUT(1).GT.1.0/RBOX(2)/2) RCUT(1) = 1.0/RBOX(2)/2 IF (RCUT(1).GT.1.0/RBOX(3)/2) RCUT(1) = 1.0/RBOX(3)/2 NRCUT(1) = INT(RCUT(1)*100.0 + 2.5) C IF (NRCUT(1).LT.LSR) NRCUT(1) = LSR IF (MXCUT.GT.NRCUT(1)) MXCUT = NRCUT(1) IF (RCUT(2).LT.0.01) RCUT(2) = 7.5 IF (RCUT(2).GT.RCUT(1)) RCUT(2) = RCUT(1) IF (RCUT(2).GT.(LSR-1)*0.01) RCUT(2) = (LSR-1)*0.01 NRCUT(2) = INT(RCUT(2)*100.0 +3.01) C C -- (0,0,0),(1,0,0),(0,1,0),(0,0,1),(1,1,0),(1,0,1),(0,1,1),(1,1,1) C N = 0 DO 110 I = 0, 1 DO 110 J = 0, 1 DO 110 K = 0, 1 N = N + 1 TRANSX(N) = I TRANSY(N) = J TRANSZ(N) = K 110 CONTINUE RETURN END C C C ======== C================================================================ INVERS SUBROUTINE INVERS (X, DET, XINV) C -------------------------------------------- Given 3 by 3 matrix X C Store determinant at DET and inverse at Xinv C REAL *8 DET, X(3,3), XINV(3,3) C DET = X(1,1)*X(2,2)*X(3,3) + X(1,2)*X(2,3)*X(3,1) + * X(1,3)*X(2,1)*X(3,2) - X(1,3)*X(2,2)*X(3,1) - * X(1,2)*X(2,1)*X(3,3) - X(1,1)*X(2,3)*X(3,2) IF (DET.EQ.0.0D0) GO TO 10 XINV(1,1) = (X(2,2)*X(3,3) - X(3,2)*X(2,3)) / DET XINV(1,2) = (X(3,2)*X(1,3) - X(1,2)*X(3,3)) / DET XINV(1,3) = (X(1,2)*X(2,3) - X(2,2)*X(1,3)) / DET XINV(2,1) = (X(2,3)*X(3,1) - X(3,3)*X(2,1)) / DET XINV(2,2) = (X(3,3)*X(1,1) - X(1,3)*X(3,1)) / DET XINV(2,3) = (X(1,3)*X(2,1) - X(2,3)*X(1,1)) / DET XINV(3,1) = (X(2,1)*X(3,2) - X(3,1)*X(2,2)) / DET XINV(3,2) = (X(3,1)*X(1,2) - X(1,1)*X(3,2)) / DET XINV(3,3) = (X(1,1)*X(2,2) - X(2,1)*X(1,2)) / DET RETURN C --------------------------------------------- TEST FOR SINGULARITY 10 IF (DET.EQ.0) WRITE (*,6180) 6180 FORMAT(5X,'*** The matrix is singular ***') RETURN END C C C ======== C================================================================ PTOXYZ C c SUBROUTINE PTOXYZ (I) c PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, c * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, c * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, c * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C c COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), c * UI(LNI), AU(LNI), AV3BP(2,L3P), c * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, c * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) c REAL *8 P,V,VP,P0,UI,AU,AV3BP c COMMON /CARTES/ H(3,3),HINV(3,3),FTOQ(3,3),RBOX(6), c * G(3,3),GINV(3,3),TRANSX(8),TRANSY(8),TRANSZ(8) CT * ,Q(3,LNI),Q0(3,LNI) c REAL *8 H,HINV,G,GINV,FTOQ,RBOX,TRANSX,TRANSY,TRANSZ C CT REAL *8 PX,PY,PZ C C -------------------------------- TRANSFORMATION OF ION COORDINATES C FROM CRYSTAL TO CARTESIAN (X,Y,Z) C CT PX = P(1,I) CT PY = P(2,I) CT PZ = P(3,I) CT Q(1,I) = H(1,1)*PX + H(1,2)*PY + H(1,3)*PZ CT Q(2,I) = H(2,1)*PX + H(2,2)*PY + H(2,3)*PZ CT Q(3,I) = H(3,1)*PX + H(3,2)*PY + H(3,3)*PZ C CT PX = P0(1,I) CT PY = P0(2,I) CT PZ = P0(3,I) CT Q0(1,I) = H(1,1)*PX + H(1,2)*PY + H(1,3)*PZ CT Q0(2,I) = H(2,1)*PX + H(2,2)*PY + H(2,3)*PZ CT Q0(3,I) = H(3,1)*PX + H(3,2)*PY + H(3,3)*PZ C RETURN c END C C C ======== C================================================================ XYZTOP SUBROUTINE XYZTOP PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /CARTES/ H(3,3),HINV(3,3),FTOQ(3,3),RBOX(6), * G(3,3),GINV(3,3),TRANSX(8),TRANSY(8),TRANSZ(8) CT * ,Q(3,LNI),Q0(3,LNI) REAL *8 H,HINV,G,GINV,FTOQ,RBOX,TRANSX,TRANSY,TRANSZ C CT REAL *8 QX,QY,QZ C C -------------------------------- TRANSFORMATION OF ION COORDINATES C FROM CARTESIAN (X,Y,Z) TO CRYSTAL C DO 100 I = 1, NTION C QX = Q(1,I) C QY = Q(2,I) C QZ = Q(3,I) C P(1,I) = HINV(1,1)*QX + HINV(1,2)*QY + HINV(1,3)*QZ C P(2,I) = HINV(2,1)*QX + HINV(2,2)*QY + HINV(2,3)*QZ C P(3,I) = HINV(3,1)*QX + HINV(3,2)*QY + HINV(3,3)*QZ C C QX = Q0(1,I) C QY = Q0(2,I) C QZ = Q0(3,I) C P0(1,I) = HINV(1,1)*QX + HINV(1,2)*QY + HINV(1,3)*QZ C P0(2,I) = HINV(2,1)*QX + HINV(2,2)*QY + HINV(2,3)*QZ C P0(3,I) = HINV(3,1)*QX + HINV(3,2)*QY + HINV(3,3)*QZ 100 CONTINUE RETURN END C C C ======== C================================================================ COULMB SUBROUTINE COULMB PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C C ------------------------------------ Table for Coulomb interaction C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES(3),PPXYZ(7),FJMOL, * T000,T050, IAXTGR, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /VECTOR/ FNV(LNV),UNV(LNV),PNV(6,LNV),ZIA(LEM),UCSELF, * ALPHA,UCSLFI(LEM), MODE, NVN, NVEC(3,LNV) REAL *8 FNV,UNV,PNV,ZIA,UCSELF,ALPHA,UCSLFI COMMON /PARAMT/ AIO(LEM),BIO(LEM),CIO(LEM),DIO(LEM),ZIO(LEM), * AIJ(LEF),BIJ(LEF),CIJ(LEF),DIJ(LEF),D4IJ(LEF), * PLIJ(LEF),RSWTCH(LEF),ZIJ(LEF), D7IJ(LEF), * ECORR,VCORR, WIO(LEM), TWEGHT, AKFI(LEM), * ANG3BP(L3P), R3BLIM(2,L3P), * FK3BP(L3P), R3BGRD(2,L3P), R3lim(2,l3p),r3limax, * I3BP(3,L3P), N3BP COMMON /TABLES/ F1(LSR,LEE),E1(LSR,LEE),F0(LTB),E0(LTB) REAL *8 F1,E1,F0,E0 COMMON /CARTES/ H(3,3),HINV(3,3),FTOQ(3,3),RBOX(6), * G(3,3),GINV(3,3),TRANSX(8),TRANSY(8),TRANSZ(8) CT * ,Q(3,LNI),Q0(3,LNI) REAL *8 H,HINV,G,GINV,FTOQ,RBOX,TRANSX,TRANSY,TRANSZ COMMON /CONSTS/ PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL REAL *8 PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL C REAL *8 XN,FCT, AL2PI,RIJ,ARIJ,PIAL2,VN2,EXPVN, * YN,UCT, PAA2,ELC2,ASP,ERFC,alphal, * ZN,PCT, Z, X0,X1,X2,X3, Y1,Y2,Y3,Y4 INTEGER *4 MXNV(6) C MODE 1 2 3 4 5 6 C MAXIMUM of NV**2 7 15 23 28 31 39 DATA MXNV / 7, 11, 15, 23, 28, 31 / C No. of NVs 40 85 125 230 309 369 510 C C ----- FUNCTION ERFC(X) : VERSION 5662 IN "COMPUTER APPROXIMATIONS" DATA X0,X1,X2,X3 / 10.00464, 8.426553, 3.460259, .5623536 / DATA Y0,Y1,Y2,Y3,Y4/ 10.00464, 19.71558, 15.70229, 6.090749, 1.0/ C ELC2 = ELC**2 DO 10 I = 1, NRCUT(1)+1 E0(I) = 0.0 F0(I) = 0.0 10 CONTINUE NVN = 0 UCSELF = 0.0D0 DO 30 IO = 1, LEL ZIA(IO) = 0.0 30 CONTINUE az = 0.0 do 40 io = 1, ncompo az = az + abs(zio(io)) 40 continue IF (MODE.LE.-998. .or. az.lt.0.00001) RETURN C --------------------------------------- Gaussian (alpha) parameter MAXNV2 = ABS(MODE) IF (MAXNV2.LE.6) THEN IF (MAXNV2.LE.0) MAXNV2 = 1 MAXNV2 = REAL(MXNV(MAXNV2)) END IF ABC2 = MAXNV2 /(RCUT(1)*2.0)**2 * 1.0001 AB = SQRT(ABC2) IF (ALPHA.LT.0.001) THEN ALPHAL = MAXNV2 * 0.064D0 + 3.714D0 + * RCUT(1) * 2.0 * 0.027D0 ALPHA = ALPHAL / (RCUT(1)*2.0D0) END IF C ------------------------------------------------------ Coulomb [1] AL2PI = 2.0D0 * ALPHA / SQRT(PI) DO 125 I = 10, NRCUT(1)+3 RIJ = REAL(I) * 0.01D0 ARIJ = 1.0D0 / RIJ C --- FUNCTION ERFC(X) : VERSION 5662 C --- in "COMPUTER APPROXIMATIONS" Z = ABS(ALPHA * RIJ) ERFC = EXP(-Z*Z) * * (X0+Z*(X1+Z*(X2+Z*X3))) / * (Y0+Z*(Y1+Z*(Y2+Z*(Y3+Z*Y4)))) ERFC = SIGN(ERFC,Z) IF (Z.LT.0.0D0) ERFC = 2.0D0 + ERFC E0(I) = ERFC * (ARIJ*1.0D8) * ELC2 F0(I) = ( AL2PI * EXP(-(ALPHA*RIJ)**2) * RIJ + ERFC ) * * (ARIJ*1.0D8)**2 * ELC2 * ARIJ 125 CONTINUE C ------------------------------------------------------ Coulomb [2] C Generate reciprocal vectors for EWALD summation C Semi-sphere part only FCT = 4.0 * ELC2 * 1.0D-8 / (VOL*1.0D-24) UCT = 2.0 * ELC2 * 1.0D-16 / (PI * VOL*1.0D-24) PCT = 2.0 * ELC2 * 1.0D-16 / (2.0D0 * PI * VOL*1.0D-24) PIAL2 = PI**2 / ALPHA**2 IL = INT(BOX(1) * AB + 1.5) JL = INT(BOX(2) * AB + 1.5) KL = INT(BOX(3) * AB + 1.5) IL2 = IL * 2 + 1 JL2 = JL * 2 + 1 KL2 = KL + 1 C DO 270 II = 1, IL2 I = IL + 1 - II XN = I * DBLE(RBOX(1)) DO 260 JJ = 1, JL2 J = JL + 1 - JJ YN = J * DBLE(RBOX(2)) DO 250 KK = 1, KL2 K = KK - 1 ZN = K * DBLE(RBOX(3)) IF (K.GT.0) GO TO 230 IF (J.LT.0) GO TO 250 IF (J.EQ.0 .AND. I.LE.0) GO TO 250 230 VN2 = XN**2 + YN**2 + ZN**2 + * 2*(XN*YN*RBOX(6) + YN*ZN*RBOX(4) + * XN*ZN*RBOX(5)) IF (VN2.GT.ABC2) GO TO 250 NVN = NVN + 1 IF (NVN.GT.LNV) THEN WRITE (*,9901) ABS(MODE),lnv 9901 FORMAT (' ******* SET [MODE] LESS THAN ',I2, * ' (LNV=',i5,') *******') STOP END IF NVEC(1,NVN) = I NVEC(2,NVN) = J NVEC(3,NVN) = K EXPVN = EXP(- VN2 * PIAL2) / VN2 FNV(NVN) = FCT * EXPVN UNV(NVN) = UCT * EXPVN PAA2 = 2.0D0 * (PIAL2 + 1.0D0/VN2) PNV(1,NVN) = PCT * (1.0D0 - PAA2 * XN**2) * EXPVN PNV(2,NVN) = PCT * (1.0D0 - PAA2 * YN**2) * EXPVN PNV(3,NVN) = PCT * (1.0D0 - PAA2 * ZN**2) * EXPVN PNV(4,NVN) = PCT * (0.0D0 - PAA2 * XN*YN) * EXPVN PNV(5,NVN) = PCT * (0.0D0 - PAA2 * XN*ZN) * EXPVN PNV(6,NVN) = PCT * (0.0D0 - PAA2 * YN*ZN) * EXPVN 250 CONTINUE 260 CONTINUE 270 CONTINUE C ------------------------------------------------------ Coulomb [3] ASP = - (ALPHA*1.0D8) * ELC2 / SQRT(PI) DO 310 IO = 1, NCOMPO UCSELF = UCSELF + DBLE(NION(IO))*ZIO(IO)**2*ASP UCSLFI(IO) = DBLE(NION(IO))*ZIO(IO)**2*ASP ZIA(IO) = ZIO(IO)*ZIO(IO)*ASP*2.0 310 CONTINUE RETURN END C C C ======== C================================================================ VWCORR SUBROUTINE VWCORR PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C C --------- Correction of energy and pressur for Van der Waals terms C COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES(3),PPXYZ(7),FJMOL, * T000,T050, IAXTGR, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /PARAMT/ AIO(LEM),BIO(LEM),CIO(LEM),DIO(LEM),ZIO(LEM), * AIJ(LEF),BIJ(LEF),CIJ(LEF),DIJ(LEF),D4IJ(LEF), * PLIJ(LEF),RSWTCH(LEF),ZIJ(LEF), D7IJ(LEF), * ECORR,VCORR, WIO(LEM), TWEGHT, AKFI(LEM), * ANG3BP(L3P), R3BLIM(2,L3P), * FK3BP(L3P), R3BGRD(2,L3P), R3lim(2,l3p),r3limax, * I3BP(3,L3P), N3BP COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME COMMON /CONSTS/ PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL REAL *8 PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL C real *8 pi4, SATOMS C PI4 = 4.0D0 * PI C BETA = CAL * 1.0D10 / ANA C IF (RUNOPT(8).EQ.'TOSIFUMI ') BETA = 1.0D-19 * 1.0D7 ECORR = 0.0D0 VCORR = 0.0D0 N = 0 DO 230 I = 1, NCOMPO DO 220 J = 1, I N = N + 1 SATOMS = NION(I) * NION(J) / VOL * PI4 C SATOMS = NION(I) * NION(J) / VOL * PI4 * BETA IF (I.EQ.J) SATOMS = SATOMS / 2.0D0 ECORR = ECORR - SATOMS*CIJ(N) / 3.0D0 / RCUT(1)**3 * - SATOMS*DIJ(N) / 5.0D0 / RCUT(1)**5 VCORR = VCORR - 6.0D0*SATOMS*CIJ(N) / 3.0D0 / RCUT(1)**3 * - 8.0D0*SATOMS*DIJ(N) / 5.0D0 / RCUT(1)**5 IF (RUNOPT(8).EQ.'MORSE-PL ') THEN ECORR = ECORR - SATOMS*D4IJ(N) / RCUT(1) * - SATOMS*D7IJ(N) / 4.0 / RCUT(1)**4 VCORR = VCORR - 4.0*SATOMS*D4IJ(N) / RCUT(1) * - 7.0*SATOMS*D7IJ(N) / 4.0 / RCUT(1)**4 END IF 220 CONTINUE 230 CONTINUE C WRITE (*,*) RCUT(2), RCUT(1) C WRITE (*,1000) ECORR*FJMOL, C * VCORR / (3.0D0*VOL*1.0D-24)*1.0D-10 C1000 FORMAT (11X, 'Ecorr=',F7.3,'kJ/mol Pcorr=',F6.3,'GPa') RETURN END C C C ======= C================================================================ MORSEP SUBROUTINE MORSEP PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C C ----------------------- IDA-GILBERT-BUSING type potential function C BORN-MAYER-HUGGINS type C plus MORSE function C plus three body C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES(3),PPXYZ(7),FJMOL, * T000,T050, IAXTGR, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /PARAMT/ AIO(LEM),BIO(LEM),CIO(LEM),DIO(LEM),ZIO(LEM), * AIJ(LEF),BIJ(LEF),CIJ(LEF),DIJ(LEF),D4IJ(LEF), * PLIJ(LEF),RSWTCH(LEF),ZIJ(LEF), D7IJ(LEF), * ECORR,VCORR, WIO(LEM), TWEGHT, AKFI(LEM), * ANG3BP(L3P), R3BLIM(2,L3P), * FK3BP(L3P), R3BGRD(2,L3P), R3lim(2,l3p),r3limax, * I3BP(3,L3P), N3BP COMMON /TABLES/ F1(LSR,LEE),E1(LSR,LEE),F0(LTB),E0(LTB) REAL *8 F1,E1,F0,E0 COMMON /PMORSE/ DMIJ(LEF), BEIJ(LEF), RSIJ(LEF), * DM1IJ(LEF), BE1IJ(LEF), DM2IJ(LEF),BE2IJ(LEF) COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME COMMON /CONSTS/ PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL REAL *8 PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL C REAL *8 EALPHA, BETA, RIJ,ARIJ, E1M,F1M, AM1,AM2, * EX, ARB, ZFORML(LEM), epsij(lef), sepij(lef) CHARACTER *40 FMT1, FMT2 C ELC2 = ELC * ELC BETA = CAL * 1.0D10 / ANA C N3BP = 0 DO 10 I = 1, l3p I3BP(1,I) = 0 i3BP(2,I) = 0 i3bp(3,i) = 0 10 CONTINUE NPAIR = NCOMPO * (NCOMPO+1) / 2 N = 0 DO 110 I = 1, NCOMPO II = I DO 100 J = 1, II N = N + 1 AIJ(N) = ABS(AIO(II) + AIO(J)) BIJ(N) = ABS(BIO(II) + BIO(J)) CIJ(N) = CIO(II) * CIO(J) * BETA DIJ(N) = 0.0 D4IJ(N) = (DIO(II)*ZIO(J)**2 + DIO(J)*ZIO(II)**2 ) / 2.0D0 * * ELC2 * 1.0D8 D7IJ(N) = 2.0D0 * ZIO(II)*ZIO(J) * DIO(II)*DIO(J) * * ELC2 * 1.0D8 DMIJ(N) = 0.0 BEIJ(N) = 0.0 RSIJ(N) = 0.0 RSWTCH(N) = 0.0 epsij(n) = 1.0 sepij(n) = 1.0 100 CONTINUE 110 CONTINUE C IF (RUNOPT(8).EQ.'MORSE '.OR.RUNOPT(8).EQ.'MORSE-AT '.OR. * RUNOPT(8).EQ.'BELONO ' ) THEN 120 READ (15,5555) IP,JP, KP, ijkl, * DIJP, BEIJP, RSIJP, R3BG 5555 FORMAT (3I2,i2,2x,5F10.0) IF (IP.NE.0.AND.MOD(IP,10).EQ.0) IP = IP / 10 IF (JP.NE.0.AND.MOD(JP,10).EQ.0) JP = JP / 10 IF (KP.NE.0.AND.MOD(KP,10).EQ.0) KP = KP / 10 IF (IP.GE.1.AND.IP.LE.NCOMPO .AND. * JP.GE.1.AND.JP.LE.NCOMPO ) THEN IF (KP.EQ.0) THEN IF (JP.GT.IP) THEN IJ = IP IP = JP JP = IJ END IF N = (IP - 1) * IP / 2 + JP DMIJ(N) = DIJP BEIJ(N) = BEIJP RSIJ(N) = RSIJP RSWTCH(N) = R3BG ELSE IF (IP.EQ.KP) THEN N3BP = N3BP +1 I3BP(1,N3BP) = IP i3BP(2,N3BP) = JP i3BP(3,N3BP) = KP C -------------------------------------- F:kJ/mol FK3BP(N3BP) = DIJP ANG3BP(N3BP) = BEIJP R3BLIM(1,N3BP) = RSIJP R3BGRD(1,N3BP) = R3BG IF (ANG3BP(N3BP).LE.0.01) ANG3BP(N3BP)= 90.0 IF (R3BLIM(1,N3BP).LE.0.01) R3BLIM(1,N3BP)= 1.2 IF (R3BGRD(1,N3BP).LE.0.01) R3BGRD(1,N3BP)=20.0 R3BLIM(2,N3BP) = R3BLIM(1,N3BP) R3BGRD(2,N3BP) = R3BGRD(1,N3BP) ELSE IF (IP.NE.KP) THEN N3BP = N3BP +1 I3BP(1,N3BP) = IP i3BP(2,N3BP) = jP i3BP(3,N3BP) = KP C ------------------------------------ F:kJ/mol FK3BP(N3BP) = DIJP ANG3BP(N3BP) = BEIJP R3BLIM(1,N3BP) = RSIJP R3BGRD(1,N3BP) = R3BG IF (ANG3BP(N3BP).LE.0.01) ANG3BP(N3BP) =90.0 IF (R3BLIM(1,N3BP).LE.0.01) R3BLIM(1,N3BP)= 1.2 IF (R3BGRD(1,N3BP).LE.0.01) R3BGRD(1,N3BP)=20.0 READ (15,5566) R3BLIM2, R3BGRD2 5566 FORMAT (30X,2F10.0) IF (R3BLIM2.LE.0.01) R3BLIM2 = R3BLIM(1,N3BP) IF (R3BGRD2.LE.0.01) R3BGRD2 = R3BGRD(1,N3BP) R3BLIM(2,N3BP) = R3BLIM2 R3BGRD(2,N3BP) = R3BGRD2 ELSE STOP 'Something wrong in potetial param.' END IF GO TO 120 END IF if (runopt(8).eq.'BELONO ') then read (15,5577) zforml 5577 format (10f5.0) N = 0 DO 131 I = 1, NCOMPO II = I DO 130 J = 1, II N = N + 1 epsij(N) = ABS(zio(II)/zforml(II))* * abs(zio(J) /zforml(J)) sepij(N) = SQRT(1.0 - epsij(N)) 130 CONTINUE 131 CONTINUE end if LCOMPO = NCOMPO IF (LCOMPO.GT.7) LCOMPO = 7 LPAIR = LCOMPO*(LCOMPO+1)/2 FMT1 = '( 2HI ,9X, 3(5X,A2,1H-,A2),90X,1HI ) ' FMT2 = '( 2HI ,2X,A6,1X, 3F10.3, 90X,1HI ) ' IF (NCOMPO.EQ.3) THEN FMT1 = '( 2HI ,9X, 6(5X,A2,1H-,A2),60X,1HI ) ' FMT2 = '( 2HI ,2X,A6,1X, 6F10.3, 60X,1HI ) ' ELSE IF (NCOMPO.EQ.4) THEN FMT1 = '( 2HI ,9X, 10(5X,A2,1H-,A2), 20X,1HI ) ' FMT2 = '( 2HI ,2X,A6,1X, 10F10.3, 20X,1HI ) ' ELSE IF (NCOMPO.EQ.5) THEN FMT1 = '( 2HI ,7X, 15(3X,A2,1H-,A2), 2X,1HI ) ' FMT2 = '( 2HI ,1X,A5,1X, 15F8.2, 2X,1HI ) ' ELSE IF (NCOMPO.EQ.6) THEN FMT1 = '( 2HI ,3X, 21(1X,A2,1H-,A2), 1HI ) ' FMT2 = '( 2HI ,A3, 21F6.2, 1HI ) ' ELSE IF (NCOMPO.EQ.7) THEN FMT1 = '( 2HI ,5X, 28(1X,A1,1H-,A1),12X,1HI ) ' FMT2 = '( 2HI ,A5, 1X, 28F4.1, 12X,1HI ) ' END IF WRITE (16, 6661) 6661 FORMAT ('I ', 60(' '), 'I--', 63('-'), '--I' ) WRITE (16,FMT1) ((ATOM(I),ATOM(J),J=1,I),I=1,LCOMPO) WRITE (16,FMT2) 'Dij ', (DMIJ(J),J=1,LPAIR) WRITE (16,FMT2) 'BEij ', (BEIJ(J),J=1,LPAIR) WRITE (16,FMT2) 'RSij ', (RSIJ(J),J=1,LPAIR) write (16,fmt2) 'Rswtch',(RSWTCH(J),j=1,lpair) if (RUNOPT(8).EQ.'BELONO ') then write (16,fmt2) 'EPij', (EPSij(J),J=1,LPAIR) write (16,fmt2) 'SEij', (SEPij(J),J=1,LPAIR) end if if (N3BP.GT.0) THEN WRITE (16,6666) 6666 FORMAT ('I ',60(' '),' ', 63(' '),' I' / * 'I',5X,'3-body potential ATOM(J)--ATOM(I)', * '--ATOM(J) FK3BP ANG3BP ', * ' R3BLIM ', * ' R3BGRD R3LIM ',15X, 'I') DO 140 N = 1, N3BP IF (I3BP(2,N)*i3BP(1,N).GT.0) THEN R3LIM(1,n) = LOG(0.999999D0/0.000001)/R3BGRD(1,N) * + R3BLIM(1,N) r3lim(2,n) = r3lim(1,n) if (r3limax.lt.r3lim(1,n)) r3limax=r3lim(1,n) WRITE (16,6667) ATOM(i3BP(1,N)), i3BP(1,N), * ATOM(I3BP(2,N)), I3BP(2,N), * ATOM(i3BP(3,N)), i3BP(3,N), * FK3BP(N),ANG3BP(N),i3bp(2,n),i3bp(1,n), * R3BLIM(1,N), R3BGRD(1,N), R3LIM(1,n) 6667 FORMAT ('I',22X, 3X,A2,'(',I2,')--', A2,'(', * I2,')--',A2,'(',I2,')', F15.8, F11.3, * i6,'-',i2, 2F10.3, F12.4,16X, 'I') if (i3BP(1,N).ne.i3BP(3,N)) then R3LIM(2,n) = LOG(0.999999D0/0.000001) / * R3BGRD(2,N) + R3BLIM(2,N) if (r3limax.lt.r3lim(2,n)) r3limax=r3lim(2,n) WRITE (16,6668) i3bp(2,n),i3bp(3,n), * R3BLIM(2,N), * R3BGRD(2,N), R3LIM(2,n) 6668 FORMAT ('I',73X, i6,'-',i2, * 2F10.3, F12.4,16X, 'I') end if END IF 140 CONTINUE END IF END IF C DO 250 I = 10, NRCUT(2) RIJ = REAL(I) * 0.01 ARIJ = 1.0 / RIJ DO 240 J = 1, NPAIR E1(I,J) = 0.0 F1(I,J) = 0.0 E1M = 0.0 F1M = 0.0 IF (ABS(AIJ(J)).LT.1.0E-5) GO TO 220 EX = 0.0 IF (BIJ(J).GT.0.00001) THEN ARB = (AIJ(J) - RIJ) / BIJ(J) IF (ARB.GT.-128.0) EX = EXP(ARB) END IF EALPHA = DIJ(J)*ARIJ**4*EXP(-RIJ/4.43)*1.6022E-12 E1(I,J) = BETA * BIJ(J)*EX*EPSIJ(J) C * - CIJ(J)*ARIJ**6 ) C * + EALPHA F1(I,J) = BETA * EX*EPSIJ(J) C * - 6.0*CIJ(J)*ARIJ**7) C * + 4.0*EALPHA*ARIJ + EALPHA/4.43 220 IF (DMIJ(J).LT.0.01) GO TO 230 IF (RUNOPT(8).EQ.'MORSE '.OR. * RUNOPT(8).EQ.'MORSE-PL '.OR. * RUNOPT(8).EQ.'BELONO ' ) THEN AM1 = EXP(-2.0*BEIJ(J)*(RIJ-RSIJ(J))) AM2 = EXP(-1.0*BEIJ(J)*(RIJ-RSIJ(J))) E1M= BETA*DMIJ(J) *(AM1 - 2.0*AM2) * SEPij(J) F1M= BETA*BEIJ(J) *DMIJ(J) * (2.0*AM1 - * 2.0*AM2) * SEPij(J) END IF IF (RUNOPT(8).EQ.'MORSE-AT ') THEN AM2 = DMIJ(J)*EXP(-BEIJ(J)*RIJ) E1M = - BETA * AM2 F1M = - BETA * BEIJ(J) * AM2 END IF IF (RSWTCH(J).LT.1.0E-6) THEN E1(I,J) = E1(I,J) + E1M F1(I,J) = F1(I,J) + F1M ELSE IF (RIJ.LE.RSWTCH(J)) THEN E1(I,J) = E1M F1(I,J) = F1M END IF 230 F1(I,J) = F1(I,J)*1.0D8 * ARIJ 240 CONTINUE 250 CONTINUE RETURN END C C C ======= C================================================================ MORSEP SUBROUTINE MORSEQ PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C C ----------------------- IDA-GILBERT-BUSING type potential function C BORN-MAYER-HUGGINS type C plus MORSE function C plus three body C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES(3),PPXYZ(7),FJMOL, * T000,T050, IAXTGR, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /PARAMT/ AIO(LEM),BIO(LEM),CIO(LEM),DIO(LEM),ZIO(LEM), * AIJ(LEF),BIJ(LEF),CIJ(LEF),DIJ(LEF),D4IJ(LEF), * PLIJ(LEF),RSWTCH(LEF),ZIJ(LEF), D7IJ(LEF), * ECORR,VCORR, WIO(LEM), TWEGHT, AKFI(LEM), * ANG3BP(L3P), R3BLIM(2,L3P), * FK3BP(L3P), R3BGRD(2,L3P), R3lim(2,l3p),r3limax, * I3BP(3,L3P), N3BP COMMON /TABLES/ F1(LSR,LEE),E1(LSR,LEE),F0(LTB),E0(LTB) REAL *8 F1,E1,F0,E0 COMMON /PMORSE/ DMIJ(LEF), BEIJ(LEF), RSIJ(LEF), * DM1IJ(LEF), BE1IJ(LEF), DM2IJ(LEF),BE2IJ(LEF) COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME COMMON /CONSTS/ PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL REAL *8 PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL C REAL *8 BETA, RIJ,ARIJ, E1M,F1M, AM1,AM2, * EX, ZFORML(LEM), epsij(lef), sepij(lef) CHARACTER *40 FMT1, FMT2 C ELC2 = ELC * ELC BETA = CAL * 1.0D10 / ANA BETAJ = 1.0D10 / ANA C N3BP = 0 DO 10 I = 1, l3p I3BP(1,I) = 0 i3BP(2,I) = 0 i3bp(3,i) = 0 10 CONTINUE NPAIR = NCOMPO * (NCOMPO+1) / 2 N = 0 DO 110 I = 1, NCOMPO II = I DO 100 J = 1, II N = N + 1 AIJ(N) = CIO(II) + CIO(J) BIJ(N) = BIO(II) * BIO(J) CIJ(N) = AIO(II)*AIO(J)*BETAJ DIJ(N) = 0.0 D4IJ(N) = 0.0 D7IJ(N) = 0.0 DMIJ(N) = 0.0 BEIJ(N) = 0.0 RSIJ(N) = 0.0 RSWTCH(N) = 0.0 epsij(n) = 1.0 sepij(n) = 1.0 100 CONTINUE 110 CONTINUE C IF (RUNOPT(8).EQ.'MORSEQ ') THEN 120 READ (15,5555) IP,JP, KP, ijkl, * DIJP, BEIJP, RSIJP, R3BG 5555 FORMAT (3I2,i2,2x,5F10.0) IF (IP.NE.0.AND.MOD(IP,10).EQ.0) IP = IP / 10 IF (JP.NE.0.AND.MOD(JP,10).EQ.0) JP = JP / 10 IF (KP.NE.0.AND.MOD(KP,10).EQ.0) KP = KP / 10 IF (IP.GE.1.AND.IP.LE.NCOMPO .AND. * JP.GE.1.AND.JP.LE.NCOMPO ) THEN IF (KP.EQ.0) THEN IF (JP.GT.IP) THEN IJ = IP IP = JP JP = IJ END IF N = (IP - 1) * IP / 2 + JP DMIJ(N) = DIJP BEIJ(N) = BEIJP RSIJ(N) = RSIJP RSWTCH(N) = R3BG ELSE IF (IP.EQ.KP) THEN N3BP = N3BP +1 I3BP(1,N3BP) = IP i3BP(2,N3BP) = JP i3BP(3,N3BP) = KP C -------------------------------------- F:kJ/mol FK3BP(N3BP) = DIJP ANG3BP(N3BP) = BEIJP R3BLIM(1,N3BP) = RSIJP R3BGRD(1,N3BP) = R3BG IF (ANG3BP(N3BP).LE.0.01) ANG3BP(N3BP)= 90.0 IF (R3BLIM(1,N3BP).LE.0.01) R3BLIM(1,N3BP)= 1.2 IF (R3BGRD(1,N3BP).LE.0.01) R3BGRD(1,N3BP)=20.0 R3BLIM(2,N3BP) = R3BLIM(1,N3BP) R3BGRD(2,N3BP) = R3BGRD(1,N3BP) ELSE IF (IP.NE.KP) THEN N3BP = N3BP +1 I3BP(1,N3BP) = IP i3BP(2,N3BP) = jP i3BP(3,N3BP) = KP C ------------------------------------ F:kJ/mol FK3BP(N3BP) = DIJP ANG3BP(N3BP) = BEIJP R3BLIM(1,N3BP) = RSIJP R3BGRD(1,N3BP) = R3BG IF (ANG3BP(N3BP).LE.0.01) ANG3BP(N3BP) =90.0 IF (R3BLIM(1,N3BP).LE.0.01) R3BLIM(1,N3BP)= 1.2 IF (R3BGRD(1,N3BP).LE.0.01) R3BGRD(1,N3BP)=20.0 READ (15,5566) R3BLIM2, R3BGRD2 5566 FORMAT (30X,2F10.0) IF (R3BLIM2.LE.0.01) R3BLIM2 = R3BLIM(1,N3BP) IF (R3BGRD2.LE.0.01) R3BGRD2 = R3BGRD(1,N3BP) R3BLIM(2,N3BP) = R3BLIM2 R3BGRD(2,N3BP) = R3BGRD2 ELSE STOP 'Something wrong in potetial param.' END IF GO TO 120 END IF if (runopt(8).eq.'BELONO ') then read (15,5577) zforml 5577 format (10f5.0) N = 0 DO 131 I = 1, NCOMPO II = I DO 130 J = 1, II N = N + 1 epsij(N) = ABS(zio(II)/zforml(II))* * abs(zio(J) /zforml(J)) sepij(N) = SQRT(1.0 - epsij(N)) 130 CONTINUE 131 CONTINUE end if LCOMPO = NCOMPO IF (LCOMPO.GT.7) LCOMPO = 7 LPAIR = LCOMPO*(LCOMPO+1)/2 FMT1 = '( 2HI ,9X, 3(5X,A2,1H-,A2),90X,1HI ) ' FMT2 = '( 2HI ,2X,A6,1X, 3F10.3, 90X,1HI ) ' IF (NCOMPO.EQ.3) THEN FMT1 = '( 2HI ,9X, 6(5X,A2,1H-,A2),60X,1HI ) ' FMT2 = '( 2HI ,2X,A6,1X, 6F10.3, 60X,1HI ) ' ELSE IF (NCOMPO.EQ.4) THEN FMT1 = '( 2HI ,9X, 10(5X,A2,1H-,A2), 20X,1HI ) ' FMT2 = '( 2HI ,2X,A6,1X, 10F10.3, 20X,1HI ) ' ELSE IF (NCOMPO.EQ.5) THEN FMT1 = '( 2HI ,7X, 15(3X,A2,1H-,A2), 2X,1HI ) ' FMT2 = '( 2HI ,1X,A5,1X, 15F8.2, 2X,1HI ) ' ELSE IF (NCOMPO.EQ.6) THEN FMT1 = '( 2HI ,3X, 21(1X,A2,1H-,A2), 1HI ) ' FMT2 = '( 2HI ,A3, 21F6.2, 1HI ) ' ELSE IF (NCOMPO.EQ.7) THEN FMT1 = '( 2HI ,5X, 28(1X,A1,1H-,A1),12X,1HI ) ' FMT2 = '( 2HI ,A5, 1X, 28F4.1, 12X,1HI ) ' END IF WRITE (16, 6661) 6661 FORMAT ('I ', 60(' '), 'I--', 63('-'), '--I' ) WRITE (16,FMT1) ((ATOM(I),ATOM(J),J=1,I),I=1,LCOMPO) WRITE (16,FMT2) 'Dij ', (DMIJ(J),J=1,LPAIR) WRITE (16,FMT2) 'BEij ', (BEIJ(J),J=1,LPAIR) WRITE (16,FMT2) 'RSij ', (RSIJ(J),J=1,LPAIR) write (16,fmt2) 'Rswtch',(RSWTCH(J),j=1,lpair) if (RUNOPT(8).EQ.'BELONO ') then write (16,fmt2) 'EPij', (EPSij(J),J=1,LPAIR) write (16,fmt2) 'SEij', (SEPij(J),J=1,LPAIR) end if if (N3BP.GT.0) THEN WRITE (16,6666) 6666 FORMAT ('I ',60(' '),' ', 63(' '),' I' / * 'I',5X,'3-body potential ATOM(J)--ATOM(I)', * '--ATOM(J) FK3BP ANG3BP ', * ' R3BLIM ', * ' R3BGRD R3LIM ',15X, 'I') DO 140 N = 1, N3BP IF (I3BP(2,N)*i3BP(1,N).GT.0) THEN R3LIM(1,n) = LOG(0.999999D0/0.000001)/R3BGRD(1,N) * + R3BLIM(1,N) r3lim(2,n) = r3lim(1,n) if (r3limax.lt.r3lim(1,n)) r3limax=r3lim(1,n) WRITE (16,6667) ATOM(i3BP(1,N)), i3BP(1,N), * ATOM(I3BP(2,N)), I3BP(2,N), * ATOM(i3BP(3,N)), i3BP(3,N), * FK3BP(N),ANG3BP(N),i3bp(2,n),i3bp(1,n), * R3BLIM(1,N), R3BGRD(1,N), R3LIM(1,n) 6667 FORMAT ('I',22X, 3X,A2,'(',I2,')--', A2,'(', * I2,')--',A2,'(',I2,')', F15.8, F11.3, * i6,'-',i2, 2F10.3, F12.4,16X, 'I') if (i3BP(1,N).ne.i3BP(3,N)) then R3LIM(2,n) = LOG(0.999999D0/0.000001) / * R3BGRD(2,N) + R3BLIM(2,N) if (r3limax.lt.r3lim(2,n)) r3limax=r3lim(2,n) WRITE (16,6668) i3bp(2,n),i3bp(3,n), * R3BLIM(2,N), * R3BGRD(2,N), R3LIM(2,n) 6668 FORMAT ('I',73X, i6,'-',i2, * 2F10.3, F12.4,16X, 'I') end if END IF 140 CONTINUE END IF END IF C DO 250 I = 10, NRCUT(2) RIJ = REAL(I) * 0.01 ARIJ = 1.0 / RIJ DO 240 J = 1, NPAIR E1(I,J) = 0.0 F1(I,J) = 0.0 E1M = 0.0 F1M = 0.0 EX = BIJ(j)*EXP(-Aij(j)*Rij) E1(I,J) = BETAj * EX F1(I,J) = BETAj * AIJ(j)*EX AM1 = EXP(-2.0*BEIJ(J)*(RIJ-RSIJ(J))) AM2 = EXP(-1.0*BEIJ(J)*(RIJ-RSIJ(J))) E1M= BETA*DMIJ(J) *(AM1 - 2.0*AM2) * SEPij(J) F1M= BETA*BEIJ(J) *DMIJ(J) * (2.0*AM1 - * 2.0*AM2) * SEPij(J) IF (RIJ.GT.RSWTCH(j)) THEN E1(I,J) = E1(I,J) F1(I,J) = F1(I,J) ELSE IF (RIJ.LE.RSWTCH(J)) THEN E1(I,J) = E1M F1(I,J) = F1M END IF 230 F1(I,J) = F1(I,J)*1.0D8 * ARIJ 240 CONTINUE 250 CONTINUE RETURN END C C C ======= C================================================================ BMHEXP SUBROUTINE BMHEXP PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C C ----------------------- IDA-GILBERT-BUSING type potential function C BORN-MAYER-HUGGINS type plus Expornential type function C plus gauss type function C plus three body C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES(3),PPXYZ(7),FJMOL, * T000,T050, IAXTGR, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /PARAMT/ AIO(LEM),BIO(LEM),CIO(LEM),DIO(LEM),ZIO(LEM), * AIJ(LEF),BIJ(LEF),CIJ(LEF),DIJ(LEF),D4IJ(LEF), * PLIJ(LEF),RSWTCH(LEF),ZIJ(LEF), D7IJ(LEF), * ECORR,VCORR, WIO(LEM), TWEGHT, AKFI(LEM), * ANG3BP(L3P), R3BLIM(2,L3P), * FK3BP(L3P), R3BGRD(2,L3P), R3lim(2,l3p),r3limax, * I3BP(3,L3P), N3BP COMMON /TABLES/ F1(LSR,LEE),E1(LSR,LEE),F0(LTB),E0(LTB) REAL *8 F1,E1,F0,E0 COMMON /PMORSE/ DMIJ(LEF), BEIJ(LEF), RSIJ(LEF), * DM1IJ(LEF), BE1IJ(LEF), DM2IJ(LEF),BE2IJ(LEF) COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME COMMON /CONSTS/ PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL REAL *8 PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL C REAL *8 EALPHA, BETA, RIJ,ARIJ, E1M,F1M, AM1,AM2, * EX, ARB, epsij(lef), sepij(lef) real *8 am3, dm3ij(lef), be3ij(lef), r03ij(lef) integer ipara(2,10), npara real *4 apara(8,10) C ELC2 = ELC * ELC BETA = CAL * 1.0D10 / ANA C N3BP = 0 DO 10 I = 1, l3p I3BP(1,I) = 0 i3BP(2,I) = 0 i3bp(3,i) = 0 10 CONTINUE NPAIR = NCOMPO * (NCOMPO+1) / 2 N = 0 DO 110 I = 1, NCOMPO II = I DO 100 J = 1, II N = N + 1 AIJ(N) = ABS(AIO(II) + AIO(J)) BIJ(N) = ABS(BIO(II) + BIO(J)) CIJ(N) = CIO(II) * CIO(J) * BETA DIJ(N) = 0.0 D4IJ(N) = (DIO(II)*ZIO(J)**2 + DIO(J)*ZIO(II)**2 ) / 2.0D0 * * ELC2 * 1.0D8 D7IJ(N) = 2.0D0 * ZIO(II)*ZIO(J) * DIO(II)*DIO(J) * * ELC2 * 1.0D8 ZIJ(N) = ZIO(I)*ZIO(J) DM1IJ(N) = 0.0 BE1IJ(N) = 0.0 DM2IJ(N) = 0.0 BE2IJ(N) = 0.0 DM3IJ(N) = 0.0 BE3IJ(N) = 0.0 r03ij(n) = 0.0 RSWTCH(N) = 0.0 epsij(n) = 1.0 sepij(n) = 1.0 100 CONTINUE 110 CONTINUE C npara = 0 120 READ (15,5555) IP,JP, KP, ijkl, * D1, BE1, D2, BE2, RSIJP, GGG 5555 FORMAT (3I2,i2,2X,6F10.0) 5556 format (10x, 3f10.0) c write (6,*) IP,JP, KP, ijkl, c * D1, BE1, D2, BE2, RSIJP, GGG IF (IP.NE.0.AND.MOD(IP,10).EQ.0) IP = IP / 10 IF (JP.NE.0.AND.MOD(JP,10).EQ.0) JP = JP / 10 IF (KP.NE.0.AND.MOD(KP,10).EQ.0) KP = KP / 10 IF (IP.GE.1.AND.IP.LE.NCOMPO .AND. * JP.GE.1.AND.JP.LE.NCOMPO ) THEN IF (KP.EQ.0) THEN IF (JP.GT.IP) THEN IJ = IP IP = JP JP = IJ END IF N = (IP - 1) * IP / 2 + JP if (ijkl.eq.1) then AIJ(N) = 0.0 BIJ(N) = 0.0 CIJ(N) = 0.0 DIJ(N) = 0.0 D4IJ(N) = 0.0 D7IJ(N) = 0.0 end if DM1IJ(N) = D1 BE1IJ(N) = BE1 DM2IJ(N) = D2 BE2IJ(N) = BE2 RSWTCH(N) = RSIJP if (ggg.gt.0.0) then read (15,5556) dm3ij(n),be3ij(n),r03ij(n) end if npara = npara + 1 ipara(1,npara) = ip ipara(2,npara) = jp apara(1,npara) = d1 apara(2,npara) = be1 apara(3,npara) = d2 apara(4,npara) = be2 apara(5,npara) = dm3ij(n) apara(6,npara) = be3ij(n) apara(7,npara) = r03ij(n) apara(8,npara) = rsijp ELSE IF (IP.EQ.KP) THEN !------------------ j-i-j N3BP = N3BP +1 I3BP(1,N3BP) = iP i3BP(2,N3BP) = jP i3BP(3,N3BP) = KP C -------------------------------------- F:kJ/mol FK3BP(N3BP) = D1 ANG3BP(N3BP) = BE1 R3BLIM(1,N3BP) = D2 R3BGRD(1,N3BP) = BE2 IF (ANG3BP(N3BP).LE.0.01) ANG3BP(N3BP) =90.0 IF (R3BLIM(1,N3BP).LE.0.01) R3BLIM(1,N3BP)= 1.2 IF (R3BGRD(1,N3BP).LE.0.01) R3BGRD(1,N3BP)=20.0 R3BLIM(2,N3BP) = R3BLIM(1,N3BP) R3BGRD(2,N3BP) = R3BGRD(1,N3BP) ELSE IF (IP.NE.KP) THEN !------------------- J-i-k N3BP = N3BP +1 c write (6,*) ip,jp,kp I3BP(1,N3BP) = iP i3BP(2,N3BP) = jP i3BP(3,N3BP) = KP C -------------------------------------- F:kJ/mol FK3BP(N3BP) = D1 ANG3BP(N3BP) = BE1 R3BLIM(1,N3BP) = D2 R3BGRD(1,N3BP) = BE2 IF (ANG3BP(N3BP).LE.0.01) ANG3BP(N3BP) =90.0 IF (R3BLIM(1,N3BP).LE.0.01) R3BLIM(1,N3BP)= 1.2 IF (R3BGRD(1,N3BP).LE.0.01) R3BGRD(1,N3BP)=20.0 READ (15,5566) R3BLIM2, R3BGRD2 5566 FORMAT (30X,2F10.0) IF (R3BLIM2.LE.0.01) R3BLIM2 = R3BLIM(1,N3BP) IF (R3BGRD2.LE.0.01) R3BGRD2 = R3BGRD(1,N3BP) R3BLIM(2,N3BP) = R3BLIM2 R3BGRD(2,N3BP) = R3BGRD2 ELSE STOP 'Something wrong in potetial param.' END IF GO TO 120 END IF C write (16,6661) 6661 format ('I ', 60(' '), 'I--', 63('-'), '--I' / * 'I ',24x,'DM1ij BE1ij DM2ij ', * ' BE2ij DM3ij BE3ij R03ij ', * ' Rswch',26x, 'I') if (npara.gt.0) then do 130 i = 1, npara WRITE (16, 6663) ATOM(Ipara(1,i)),ipara(1,i), * ATOM(ipara(2,i)),ipara(2,i), (apara(j,i),j=1,8) 6663 format ('I ',A2,'(',i2,') -- ',A2,'(',i2,') ', * 3(F11.2, F10.3),F10.3,F10.3, 26X,'I') 130 continue end if C if (N3BP.GT.0) THEN WRITE (16,6666) 6666 FORMAT ('I ',60(' '),' ', 63(' '),' I' / * 'I',5X,'3-body potential ATOM(J)--ATOM(I)', * '--ATOM(J) FK3BP ANG3BP ', * ' R3BLIM ', * ' R3BGRD R3LIM ',15X, 'I') DO 140 N = 1, N3BP IF (I3BP(2,N)*i3BP(1,N).GT.0) THEN R3LIM(1,n) = LOG(0.999999D0/0.000001)/R3BGRD(1,N) * + R3BLIM(1,N) if (runopt(8).eq.'BMH-EXP* ') then R3LIM(1,n) = LOG(0.9999D0/0.0001D0) / * R3BGRD(1,N) + R3BLIM(1,N) end if r3lim(2,n) = r3lim(1,n) if (r3limax.lt.r3lim(1,n)) r3limax=r3lim(1,n) WRITE (16,6667) ATOM(i3BP(1,N)), i3BP(1,N), * ATOM(I3BP(2,N)), I3BP(2,N), * ATOM(i3BP(3,N)), i3BP(3,N), * FK3BP(N),ANG3BP(N),i3bp(2,n),i3bp(1,n), * R3BLIM(1,N), R3BGRD(1,N), R3LIM(1,n) 6667 FORMAT ('I',22X, 3X,A2,'(',I2,')--', A2,'(', * I2,')--',A2,'(',I2,')', F15.8, F11.3, * i6,'-',i2, 2F10.3, F12.4,16X, 'I') if (i3BP(1,N).ne.i3BP(3,N)) then R3LIM(2,n) = LOG(0.999999D0/0.000001) / * R3BGRD(2,N) + R3BLIM(2,N) if (runopt(8).eq.'BMH-EXP* ') then R3LIM(2,n) = LOG(0.9999D0/0.0001D0) / * R3BGRD(2,N) + R3BLIM(2,N) end if if (r3limax.lt.r3lim(2,n)) r3limax=r3lim(2,n) WRITE (16,6668) i3bp(2,n),i3bp(3,n), * R3BLIM(2,N), * R3BGRD(2,N), R3LIM(2,n) 6668 FORMAT ('I',73X, i6,'-',i2, * 2F10.3, F12.4,16X, 'I') end if END IF 140 CONTINUE END IF C DO 250 I = 10, NRCUT(2) RIJ = REAL(I) * 0.01 ARIJ = 1.0 / RIJ DO 240 J = 1, NPAIR E1(I,J) = 0.0 F1(I,J) = 0.0 E1M = 0.0 F1M = 0.0 IF (ABS(AIJ(J)).LT.1.0E-5) GO TO 220 EX = 0.0 IF (BIJ(J).GT.0.00001) THEN ARB = (AIJ(J) - RIJ) / BIJ(J) IF (ARB.GT.-128.0) EX = EXP(ARB) END IF EALPHA = DIJ(J)*ARIJ**4*EXP(-RIJ/4.43)*1.6022E-12 E1(I,J) = BETA * BIJ(J)*EX*EPSIJ(J) c * - CIJ(J)*ARIJ**6 C * - D4IJ(J)*ARIJ**4 - D7IJ(J)*ARIJ**7 F1(I,J) = BETA * EX*EPSIJ(J) c * - 6.0*CIJ(J)*ARIJ**7 C * - 4.0*D4IJ(J)*ARIJ**5 - 7.0*D7IJ(J)*ARIJ**8 C * - 4.0*D4IJ(J)*ARIJ**5 - D4IJ(J)*ARIJ**4/4.43 C 220 AM1 = DM1IJ(J)*EXP(-BE1IJ(J)*RIJ) AM2 = DM2IJ(J)*EXP(-BE2IJ(J)*RIJ) am3 = dm3ij(j)*exp(-be3ij(j)*(rij-r03ij(j))**2) E1M = BETA * (AM1 + AM2 + am3) F1M = BETA * (BE1IJ(J)*AM1 + BE2IJ(J)*AM2 + * 2.0*be3ij(j)*(rij-r03ij(j))*am3) IF (RSWTCH(J).LT.1.0E-6) THEN E1(I,J) = E1(I,J) + E1M F1(I,J) = F1(I,J) + F1M ELSE IF (RIJ.LE.RSWTCH(J)) THEN E1(I,J) = E1M F1(I,J) = F1M END IF 230 F1(I,J) = F1(I,J)*1.0D8 * ARIJ 240 CONTINUE 250 CONTINUE RETURN END C C C ======= C================================================================ BMHEXP SUBROUTINE BMHEXPQ PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C C ----------------------- IDA-GILBERT-BUSING type potential function C BORN-MAYER-HUGGINS type plus Expornential type function C plus gauss type function C plus three body C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES(3),PPXYZ(7),FJMOL, * T000,T050, IAXTGR, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /PARAMT/ AIO(LEM),BIO(LEM),CIO(LEM),DIO(LEM),ZIO(LEM), * AIJ(LEF),BIJ(LEF),CIJ(LEF),DIJ(LEF),D4IJ(LEF), * PLIJ(LEF),RSWTCH(LEF),ZIJ(LEF), D7IJ(LEF), * ECORR,VCORR, WIO(LEM), TWEGHT, AKFI(LEM), * ANG3BP(L3P), R3BLIM(2,L3P), * FK3BP(L3P), R3BGRD(2,L3P), R3lim(2,l3p),r3limax, * I3BP(3,L3P), N3BP COMMON /TABLES/ F1(LSR,LEE),E1(LSR,LEE),F0(LTB),E0(LTB) REAL *8 F1,E1,F0,E0 COMMON /PMORSE/ DMIJ(LEF), BEIJ(LEF), RSIJ(LEF), * DM1IJ(LEF), BE1IJ(LEF), DM2IJ(LEF),BE2IJ(LEF) COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME COMMON /CONSTS/ PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL REAL *8 PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL C REAL *8 BETA, RIJ,ARIJ, E1M,F1M, AM1,AM2, * EX, epsij(lef), sepij(lef) real *8 am3, dm3ij(lef), be3ij(lef), r03ij(lef) integer ipara(2,10), npara real *4 apara(8,10) C ELC2 = ELC * ELC BETA = CAL * 1.0D10 / ANA BETAJ = 1.0D10 / ANA C N3BP = 0 DO 10 I = 1, l3p I3BP(1,I) = 0 i3BP(2,I) = 0 i3bp(3,i) = 0 10 CONTINUE NPAIR = NCOMPO * (NCOMPO+1) / 2 N = 0 DO 110 I = 1, NCOMPO II = I DO 100 J = 1, II N = N + 1 AIJ(N) = CIO(II) + CIO(J) BIJ(N) = BIO(II) * BIO(J) CIJ(N) = AIO(II) * AIO(J) * BETAJ DIJ(N) = 0.0 D4IJ(N) = 0.0 D7IJ(N) = 0.0 ZIJ(N) = ZIO(II)*ZIO(J) DM1IJ(N) = 0.0 BE1IJ(N) = 0.0 DM2IJ(N) = 0.0 BE2IJ(N) = 0.0 DM3IJ(N) = 0.0 BE3IJ(N) = 0.0 r03ij(n) = 0.0 RSWTCH(N) = 0.0 epsij(n) = 1.0 sepij(n) = 1.0 100 CONTINUE 110 CONTINUE C npara = 0 120 READ (15,5555) IP,JP, KP, ijkl, * D1, BE1, D2, BE2, RSIJP, GGG 5555 FORMAT (3I2,i2,2X,6F10.0) 5556 format (10x, 3f10.0) c write (6,*) IP,JP, KP, ijkl, c * D1, BE1, D2, BE2, RSIJP, GGG IF (IP.NE.0.AND.MOD(IP,10).EQ.0) IP = IP / 10 IF (JP.NE.0.AND.MOD(JP,10).EQ.0) JP = JP / 10 IF (KP.NE.0.AND.MOD(KP,10).EQ.0) KP = KP / 10 IF (IP.GE.1.AND.IP.LE.NCOMPO .AND. * JP.GE.1.AND.JP.LE.NCOMPO ) THEN IF (KP.EQ.0) THEN IF (JP.GT.IP) THEN IJ = IP IP = JP JP = IJ END IF N = (IP - 1) * IP / 2 + JP if (ijkl.eq.1) then AIJ(N) = 0.0 BIJ(N) = 0.0 CIJ(N) = 0.0 DIJ(N) = 0.0 D4IJ(N) = 0.0 D7IJ(N) = 0.0 end if DM1IJ(N) = D1 BE1IJ(N) = BE1 DM2IJ(N) = D2 BE2IJ(N) = BE2 RSWTCH(N) = RSIJP if (ggg.gt.0.0) then read (15,5556) dm3ij(n),be3ij(n),r03ij(n) end if npara = npara + 1 ipara(1,npara) = ip ipara(2,npara) = jp apara(1,npara) = d1 apara(2,npara) = be1 apara(3,npara) = d2 apara(4,npara) = be2 apara(5,npara) = dm3ij(n) apara(6,npara) = be3ij(n) apara(7,npara) = r03ij(n) apara(8,npara) = rsijp ELSE IF (IP.EQ.KP) THEN !------------------ j-i-j N3BP = N3BP +1 I3BP(1,N3BP) = iP i3BP(2,N3BP) = jP i3BP(3,N3BP) = KP C -------------------------------------- F:kJ/mol FK3BP(N3BP) = D1 ANG3BP(N3BP) = BE1 R3BLIM(1,N3BP) = D2 R3BGRD(1,N3BP) = BE2 IF (ANG3BP(N3BP).LE.0.01) ANG3BP(N3BP) =90.0 IF (R3BLIM(1,N3BP).LE.0.01) R3BLIM(1,N3BP)= 1.2 IF (R3BGRD(1,N3BP).LE.0.01) R3BGRD(1,N3BP)=20.0 R3BLIM(2,N3BP) = R3BLIM(1,N3BP) R3BGRD(2,N3BP) = R3BGRD(1,N3BP) ELSE IF (IP.NE.KP) THEN !------------------- J-i-k N3BP = N3BP +1 c write (6,*) ip,jp,kp I3BP(1,N3BP) = iP i3BP(2,N3BP) = jP i3BP(3,N3BP) = KP C -------------------------------------- F:kJ/mol FK3BP(N3BP) = D1 ANG3BP(N3BP) = BE1 R3BLIM(1,N3BP) = D2 R3BGRD(1,N3BP) = BE2 IF (ANG3BP(N3BP).LE.0.01) ANG3BP(N3BP) =90.0 IF (R3BLIM(1,N3BP).LE.0.01) R3BLIM(1,N3BP)= 1.2 IF (R3BGRD(1,N3BP).LE.0.01) R3BGRD(1,N3BP)=20.0 READ (15,5566) R3BLIM2, R3BGRD2 5566 FORMAT (30X,2F10.0) IF (R3BLIM2.LE.0.01) R3BLIM2 = R3BLIM(1,N3BP) IF (R3BGRD2.LE.0.01) R3BGRD2 = R3BGRD(1,N3BP) R3BLIM(2,N3BP) = R3BLIM2 R3BGRD(2,N3BP) = R3BGRD2 ELSE STOP 'Something wrong in potetial param.' END IF GO TO 120 END IF C write (16,6661) 6661 format ('I ', 60(' '), 'I--', 63('-'), '--I' / * 'I ',24x,'DM1ij BE1ij DM2ij ', * ' BE2ij DM3ij BE3ij R03ij ', * ' Rswch',26x, 'I') if (npara.gt.0) then do 130 i = 1, npara WRITE (16, 6663) ATOM(Ipara(1,i)),ipara(1,i), * ATOM(ipara(2,i)),ipara(2,i), (apara(j,i),j=1,8) 6663 format ('I ',A2,'(',i2,') -- ',A2,'(',i2,') ', * 3(F11.2, F10.3),F10.3,F10.3, 26X,'I') 130 continue end if C if (N3BP.GT.0) THEN WRITE (16,6666) 6666 FORMAT ('I ',60(' '),' ', 63(' '),' I' / * 'I',5X,'3-body potential ATOM(J)--ATOM(I)', * '--ATOM(J) FK3BP ANG3BP ', * ' R3BLIM ', * ' R3BGRD R3LIM ',15X, 'I') DO 140 N = 1, N3BP IF (I3BP(2,N)*i3BP(1,N).GT.0) THEN R3LIM(1,n) = LOG(0.999999D0/0.000001)/R3BGRD(1,N) * + R3BLIM(1,N) if (runopt(8).eq.'BMH-EXP* ') then R3LIM(1,n) = LOG(0.9999D0/0.0001D0) / * R3BGRD(1,N) + R3BLIM(1,N) end if r3lim(2,n) = r3lim(1,n) if (r3limax.lt.r3lim(1,n)) r3limax=r3lim(1,n) WRITE (16,6667) ATOM(i3BP(1,N)), i3BP(1,N), * ATOM(I3BP(2,N)), I3BP(2,N), * ATOM(i3BP(3,N)), i3BP(3,N), * FK3BP(N),ANG3BP(N),i3bp(2,n),i3bp(1,n), * R3BLIM(1,N), R3BGRD(1,N), R3LIM(1,n) 6667 FORMAT ('I',22X, 3X,A2,'(',I2,')--', A2,'(', * I2,')--',A2,'(',I2,')', F15.8, F11.3, * i6,'-',i2, 2F10.3, F12.4,16X, 'I') if (i3BP(1,N).ne.i3BP(3,N)) then R3LIM(2,n) = LOG(0.999999D0/0.000001) / * R3BGRD(2,N) + R3BLIM(2,N) if (runopt(8).eq.'BMH-EXP* ') then R3LIM(2,n) = LOG(0.9999D0/0.0001D0) / * R3BGRD(2,N) + R3BLIM(2,N) end if if (r3limax.lt.r3lim(2,n)) r3limax=r3lim(2,n) WRITE (16,6668) i3bp(2,n),i3bp(3,n), * R3BLIM(2,N), * R3BGRD(2,N), R3LIM(2,n) 6668 FORMAT ('I',73X, i6,'-',i2, * 2F10.3, F12.4,16X, 'I') end if END IF 140 CONTINUE END IF C DO 250 I = 10, NRCUT(2) RIJ = REAL(I) * 0.01 ARIJ = 1.0 / RIJ DO 240 J = 1, NPAIR E1(I,J) = 0.0 F1(I,J) = 0.0 E1M = 0.0 F1M = 0.0 EX = BIJ(j)*EXP(-AIJ(J)*RIJ) E1(I,J) = BETAj * EX F1(I,J) = BETAj * AIJ(j)*EX AM1 = DM1IJ(J)*EXP(-BE1IJ(J)*RIJ) AM2 = DM2IJ(J)*EXP(-BE2IJ(J)*RIJ) am3 = dm3ij(j)*exp(-be3ij(j)*(rij-r03ij(j))**2) E1M = BETA * (AM1 + AM2 + am3) F1M = BETA * (BE1IJ(J)*AM1 + BE2IJ(J)*AM2 + * 2.0*be3ij(j)*(rij-r03ij(j))*am3) IF (RIJ.LE.RSWTCH(J)) THEN E1(I,J) = E1M F1(I,J) = F1M END IF 230 F1(I,J) = F1(I,J)*1.0D8 * ARIJ 240 CONTINUE 250 CONTINUE RETURN END C C C ======== C================================================================ PAIR-P SUBROUTINE PAIRP PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C C ----------------------- IDA-GILBERT-BUSING type potential function C BORN-MAYER-HUGGINS type C plus MORSE function C plus three body C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES(3),PPXYZ(7),FJMOL, * T000,T050, IAXTGR, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /PARAMT/ AIO(LEM),BIO(LEM),CIO(LEM),DIO(LEM),ZIO(LEM), * AIJ(LEF),BIJ(LEF),CIJ(LEF),DIJ(LEF),D4IJ(LEF), * PLIJ(LEF),RSWTCH(LEF),ZIJ(LEF), D7IJ(LEF), * ECORR,VCORR, WIO(LEM), TWEGHT, AKFI(LEM), * ANG3BP(L3P), R3BLIM(2,L3P), * FK3BP(L3P), R3BGRD(2,L3P), R3lim(2,l3p),r3limax, * I3BP(3,L3P), N3BP COMMON /TABLES/ F1(LSR,LEE),E1(LSR,LEE),F0(LTB),E0(LTB) REAL *8 F1,E1,F0,E0 COMMON /PMORSE/ DMIJ(LEF), BEIJ(LEF), RSIJ(LEF), * DM1IJ(LEF), BE1IJ(LEF), DM2IJ(LEF),BE2IJ(LEF) COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME COMMON /CONSTS/ PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL REAL *8 PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL C REAL *8 BETA, RIJ,ARIJ, EX, ARB character *40 fmt1, fmt2 C c beta = 1.0d0 / 6.2415064d11 ! eV -> erg beta = 1.0d7 * 1000.0 / ANA ! kJ/mol -> erg C NPAIR = NCOMPO * (NCOMPO+1) / 2 N = 0 DO 110 I = 1, NCOMPO II = I DO 100 J = 1, II N = N + 1 AIJ(N) = 0.0 BIJ(N) = 0.0 CIJ(N) = 0.0 DIJ(N) = 0.0 ZIJ(N) = ZIO(I)*ZIO(J) DMIJ(N) = 0.0 BEIJ(N) = 0.0 100 CONTINUE 110 CONTINUE C 120 READ (15,5555) IP,JP, KP, DIJP, BEIJP, RSIJP, R3BG 5555 FORMAT (3I2,4X,5F10.0) IF (IP.NE.0.AND.MOD(IP,10).EQ.0) IP = IP / 10 IF (JP.NE.0.AND.MOD(JP,10).EQ.0) JP = JP / 10 IF (KP.NE.0.AND.MOD(KP,10).EQ.0) KP = KP / 10 IF (IP.GE.1.AND.IP.LE.NCOMPO .AND. * JP.GE.1.AND.JP.LE.NCOMPO ) THEN IF (KP.EQ.0) THEN IF (JP.GT.IP) THEN IJ = IP IP = JP JP = IJ END IF N = (IP - 1) * IP / 2 + JP AIJ(N) = DIJP BIJ(N) = BEIJP CIJ(N) = RSIJP * BETA if (IP.EQ.JP) then CIO(IP) = SQRT(CIJ(N)) end if end if GO TO 120 END IF LCOMPO = NCOMPO IF (LCOMPO.GT.7) LCOMPO = 7 LPAIR = LCOMPO*(LCOMPO+1)/2 FMT1 = '( 3H I ,9X, 3(5X,A2,1H-,A2),90X,1HI )' FMT2 = '( 3H I ,4X,A4,1X, 3F10.2, 90X,1HI )' IF (NCOMPO.EQ.3) THEN FMT1 = '( 3H I ,9X, 6(5X,A2,1H-,A2),60X,1HI )' FMT2 = '( 3H I ,4X,A4,1X, 6F10.2, 60X,1HI )' ELSE IF (NCOMPO.EQ.4) THEN FMT1 = '( 3H I ,9X, 10(5X,A2,1H-,A2), 20X,1HI )' FMT2 = '( 3H I ,4X,A4,1X, 10F10.2, 20X,1HI )' ELSE IF (NCOMPO.EQ.5) THEN FMT1 = '( 3H I ,7X, 15(3X,A2,1H-,A2), 2X,1HI )' FMT2 = '( 3H I ,2X,A4,1X, 15F8.1, 2X,1HI )' ELSE IF (NCOMPO.EQ.6) THEN FMT1 = '( 3H I ,3X, 21(1X,A2,1H-,A2), 1HI )' FMT2 = '( 3H I ,A3, 21F6.0, 1HI )' ELSE IF (NCOMPO.EQ.7) THEN FMT1 = '( 3H I ,5X, 28(1X,A1,1H-,A1),12X,1HI )' FMT2 = '( 3H I ,1X,A4,1X, 28F4.1, 12X,1HI )' END IF WRITE (16, 6661) 6661 FORMAT ('I ', 60(' '), 'I--', 63('-'), '--I' ) WRITE (16,FMT1) ((ATOM(I),ATOM(J),J=1,I),I=1,LCOMPO) WRITE (16,FMT2) 'Aij ', (AIJ(J),J=1,LPAIR) WRITE (16,FMT2) 'Bij ', (BIJ(J),J=1,LPAIR) WRITE (16,FMT2) 'Cij ', (CIJ(J)/BETA,J=1,LPAIR) C DO 250 I = 10, NRCUT(2) RIJ = REAL(I) * 0.01 ARIJ = 1.0 / RIJ DO 240 J = 1, NPAIR E1(I,J) = 0.0 F1(I,J) = 0.0 IF (ABS(AIJ(J)).LT.1.0E-5) GO TO 240 EX = 0.0 IF (BIJ(J).GT.0.00001) THEN ARB = - RIJ / BIJ(J) IF (ARB.GT.-128.0) EX = EXP(ARB) END IF E1(I,J) = BETA * AIJ(J)*EX C * - BETA * CIJ(J)*ARIJ**6 F1(I,J) = BETA * AIJ(J) *EX / BIJ(J) C * - BETA * 6.0*CIJ(J)*ARIJ**7 F1(I,J) = F1(I,J)*1.0D8 * ARIJ 240 CONTINUE 250 CONTINUE RETURN END C C C ======== C================================================================ BUSING SUBROUTINE BUSING PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C C ----------------------- IDA-GILBERT-BUSING type potential function C BORN-MAYER-HUGGINS type C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES(3),PPXYZ(7),FJMOL, * T000,T050, IAXTGR, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /PARAMT/ AIO(LEM),BIO(LEM),CIO(LEM),DIO(LEM),ZIO(LEM), * AIJ(LEF),BIJ(LEF),CIJ(LEF),DIJ(LEF),D4IJ(LEF), * PLIJ(LEF),RSWTCH(LEF),ZIJ(LEF), D7IJ(LEF), * ECORR,VCORR, WIO(LEM), TWEGHT, AKFI(LEM), * ANG3BP(L3P), R3BLIM(2,L3P), * FK3BP(L3P), R3BGRD(2,L3P), R3lim(2,l3p),r3limax, * I3BP(3,L3P), N3BP COMMON /TABLES/ F1(LSR,LEE),E1(LSR,LEE),F0(LTB),E0(LTB) REAL *8 F1,E1,F0,E0 COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME COMMON /CONSTS/ PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL REAL *8 PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL C REAL *8 BETA,EX,RIJ,ARIJ,ARB C BETA = CAL * 1.0D10 / ANA C NPAIR = NCOMPO * (NCOMPO+1) / 2 N = 0 DO 110 I = 1, NCOMPO II = I DO 100 J = 1, II N = N + 1 AIJ(N) = ABS(AIO(II) + AIO(J)) BIJ(N) = ABS(BIO(II) + BIO(J)) CIJ(N) = CIO(II) * CIO(J) * BETA DIJ(N) = DIO(II) * DIO(J) * BETA D4IJ(N) = 0.0 D7IJ(N) = 0.0 ZIJ(N) = ZIO(I) * ZIO(J) IF (RUNOPT(8).EQ.'STSUNE ') THEN IF (I.EQ.J .AND. ATOM(I).EQ.'SI ') CIJ(N) = 0.0 END IF 100 CONTINUE 110 CONTINUE C DO 150 I = 10, NRCUT(2) RIJ = REAL(I) * 0.01 ARIJ = 1.0 / RIJ DO 140 J = 1, LEE E1(I,J) = 0.0 F1(I,J) = 0.0 IF (ABS(AIJ(J)).LT.1.0E-5) GO TO 140 EX = 0.0 IF (BIJ(J).GT.0.0001) THEN ARB = (AIJ(J) - RIJ) / BIJ(J) IF (ARB.GT.-128.0) EX = EXP(ARB) END IF E1(I,J) = BETA * BIJ(J)*EX C * - CIJ(J)*ARIJ**6 F1(I,J) = BETA * EX * 1.0D8 * ARIJ C F1(I,J) = BETA * (EX - 6.0*CIJ(J)*ARIJ**7) * C * 1.0D8 * ARIJ 140 CONTINUE 150 CONTINUE C RETURN END C C C ======== C================================================================ TOSIFU SUBROUTINE TOSIFU PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C C -------------------- TOSI & FUMI (BORN-MAYER) type rigid ion model C (including Pauling factor) C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES(3),PPXYZ(7),FJMOL, * T000,T050, IAXTGR, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /PARAMT/ AIO(LEM),BIO(LEM),CIO(LEM),DIO(LEM),ZIO(LEM), * AIJ(LEF),BIJ(LEF),CIJ(LEF),DIJ(LEF),D4IJ(LEF), * PLIJ(LEF),RSWTCH(LEF),ZIJ(LEF), D7IJ(LEF), * ECORR,VCORR, WIO(LEM), TWEGHT, AKFI(LEM), * ANG3BP(L3P), R3BLIM(2,L3P), * FK3BP(L3P), R3BGRD(2,L3P), R3lim(2,l3p),r3limax, * I3BP(3,L3P), N3BP COMMON /TABLES/ F1(LSR,LEE),E1(LSR,LEE),F0(LTB),E0(LTB) REAL *8 F1,E1,F0,E0 COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME COMMON /CONSTS/ PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL REAL *8 PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL C REAL *8 BETA, ARIJ C BETA = 1.0D-19 * 1.0D7 C NPAIR = NCOMPO * (NCOMPO+1) / 2 N = 0 DO 220 I = 1, NCOMPO II = I DO 210 J = 1, II N = N + 1 AIJ(N) = AIO(II) + AIO(J) BIJ(N) = BIO(II) + BIO(J) CIJ(N) = CIO(II) * CIO(J) * BETA DIJ(N) = DIO(II) * DIO(J) * BETA ZIJ(N) = ZIO(I) * ZIO(J) PLIJ(N) = 1.0 C ------------------------------------------- Pauling factor DENI = 8.0 IF (WIO(I).LE.11.5) DENI = 2.0 DENJ = 8.0 IF (WIO(J).LE.11.5) DENJ = 2.0 PLIJ(N) = 1.0 + ZIO(I)/DENI + ZIO(J)/DENJ 210 CONTINUE 220 CONTINUE C C RHO = 0.29 DO 250 I = 10, NRCUT(2) RIJ = REAL(I) * 0.01 ARIJ = 1.0D0 / RIJ DO 240 J = 1, NPAIR IF (ABS(AIJ(J)).GT.1.0E-5) THEN EXPA = 0.0 ARB = (AIJ(J) - RIJ) / BIJ(J) IF (ARB.GT.-128.0) EXPA = PLIJ(J) * 0.338 * EXP(ARB) E1(I,J) = EXPA * BETA C * - CIJ(J)*ARIJ**6 - DIJ(J)*ARIJ**8)*BETA F1(I,J) = EXPA/BIJ(J)*BETA * 1.0D8 * ARIJ C F1(I,J) = (EXPA/BIJ(J) - 6.0*CIJ(J)*ARIJ**7 C * - 8.0*DIJ(J)*ARIJ**9) C * * BETA * 1.0D8 * ARIJ END IF 240 CONTINUE 250 CONTINUE RETURN END C C C ======= C================================================================= ANGEL SUBROUTINE ANGELP PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C C -------------------------- BORN-MAYER-HUGGINS type rigid ion model C WOODCOK, ANGELL type potential function (Pauling factor) C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES(3),PPXYZ(7),FJMOL, * T000,T050, IAXTGR, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /PARAMT/ AIO(LEM),BIO(LEM),CIO(LEM),DIO(LEM),ZIO(LEM), * AIJ(LEF),BIJ(LEF),CIJ(LEF),DIJ(LEF),D4IJ(LEF), * PLIJ(LEF),RSWTCH(LEF),ZIJ(LEF), D7IJ(LEF), * ECORR,VCORR, WIO(LEM), TWEGHT, AKFI(LEM), * ANG3BP(L3P), R3BLIM(2,L3P), * FK3BP(L3P), R3BGRD(2,L3P), R3lim(2,l3p),r3limax, * I3BP(3,L3P), N3BP COMMON /TABLES/ F1(LSR,LEE),E1(LSR,LEE),F0(LTB),E0(LTB) REAL *8 F1,E1,F0,E0 COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME COMMON /CONSTS/ PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL REAL *8 PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL C N = 0 DO 220 I = 1, NCOMPO II = I DO 210 J = 1, II N = (II-1)*LEL +J -(2*LEL-II)*(II-1)/2 AIJ(N) = ABS(AIO(II) + AIO(J)) BIJ(N) = (BIO(II) +BIO(J)) * 1.0E-13 CIJ(N) = CIO(II) * CIO(J) * 1.0E-13 ZIJ(N) = ZIO(I) * ZIO(J) PLIJ(N) = 1.0 IF (RUNOPT(8).EQ.'PAULING ') THEN DENI = 8.0 IF (WIO(I).LE.11.5) DENI = 2.0 DENJ = 8.0 IF (WIO(J).LE.11.5) DENJ = 2.0 PLIJ(N) = 1.0 + ZIO(I)/DENI + ZIO(J)/DENJ END IF 210 CONTINUE 220 CONTINUE C C BETA = CAL * 1.0E10 / ANA RHO = 0.29 DO 250 I = 10, NRCUT(2) RIJ = REAL(I) * 0.01 ARIJ = 1.0 / RIJ DO 240 J = 1, LEE IF (ABS(AIJ(J)).GT.1.0E-5) THEN EX = 0.0 ARB = (AIJ(J) - RIJ) / RHO IF (ARB.GT.-128.0) EX = PLIJ(J) * BIJ(J) * EXP(ARB) E1(I,J) = EX C * - CIJ(J)*ARIJ**6 F1(I,J) = EX/RHO * 1.0D8 * ARIJ C F1(I,J) = (EX/RHO - 6.*CIJ(J)*ARIJ**7)*1.0D8 * ARIJ END IF 240 CONTINUE 250 CONTINUE RETURN END C C C =========== C============================================================= L-J MODEL SUBROUTINE LJMODL PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C C ------------------------------- Lennard-Jones type potential model C uij(rij) = eij[(sij/rij)**12 - (sij/rij)**6] C Lorentz-Berthelot type pair parameters C sij=(si+sj)/2 : eij=(eixej)**(1/2) C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES(3),PPXYZ(7),FJMOL, * T000,T050, IAXTGR, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2), MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /PARAMT/ AIO(LEM),BIO(LEM),CIO(LEM),DIO(LEM),ZIO(LEM), * AIJ(LEF),BIJ(LEF),CIJ(LEF),DIJ(LEF),D4IJ(LEF), * PLIJ(LEF),RSWTCH(LEF),ZIJ(LEF), D7IJ(LEF), * ECORR,VCORR, WIO(LEM), TWEGHT, AKFI(LEM), * ANG3BP(L3P), R3BLIM(2,L3P), * FK3BP(L3P), R3BGRD(2,L3P), R3lim(2,l3p),r3limax, * I3BP(3,L3P), N3BP COMMON /TABLES/ F1(LSR,LEE),E1(LSR,LEE),F0(LTB),E0(LTB) REAL *8 F1,E1,F0,E0 COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME COMMON /CONSTS/ PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL REAL *8 PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL C N = 0 DO 220 I = 1, NCOMPO AIO(I) = SQRT(AIO(I)*1.0E-16) BIO(I) = BIO(I) / 2 II = I DO 210 J = 1, II N = (II-1)*LEL +J -(2*LEL-II)*(II-1)/2 AIJ(N) = AIO(II) * AIO(J) * 4.0 BIJ(N) = BIO(II) + BIO(J) CIJ(N) = AIJ(N) * BIJ(N)**6 DIJ(N) = 0.0 ZIJ(N) = ZIO(I) * ZIO(J) if (IION(i).lt.0 .and. iion(j).lt.0) then aij(n) = 0.0 bij(n) = 0.0 cij(n) = 0.0 end if 210 CONTINUE 220 CONTINUE C DO 250 I = 10, NRCUT(2) RIJ = REAL(I) * 0.01 ARIJ = 1.0 / RIJ DO 240 J = 1, LEE EX = (BIJ(J) * ARIJ)**6 EX2 = EX * EX E1(I,J) = AIJ(J)* (EX2) C E1(I,J) = AIJ(J)* (EX2 - EX) F1(I,J) = AIJ(J)* (12.0*EX2) *ARIJ *ARIJ *1.0E8 C F1(I,J) = AIJ(J)* (12.0*EX2 - 6.0*EX) *ARIJ *ARIJ *1.0E8 240 CONTINUE 250 CONTINUE RETURN END C C C ======= C================================================================ METALP SUBROUTINE METALP (IPR) PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES(3),PPXYZ(7),FJMOL, * T000,T050, IAXTGR, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /PARAMT/ AIO(LEM),BIO(LEM),CIO(LEM),DIO(LEM),ZIO(LEM), * AIJ(LEF),BIJ(LEF),CIJ(LEF),DIJ(LEF),D4IJ(LEF), * PLIJ(LEF),RSWTCH(LEF),ZIJ(LEF), D7IJ(LEF), * ECORR,VCORR, WIO(LEM), TWEGHT, AKFI(LEM), * ANG3BP(L3P), R3BLIM(2,L3P), * FK3BP(L3P), R3BGRD(2,L3P), R3lim(2,l3p),r3limax, * I3BP(3,L3P), N3BP COMMON /TABLES/ F1(LSR,LEE),E1(LSR,LEE),F0(LTB),E0(LTB) REAL *8 F1,E1,F0,E0 COMMON /VECTOR/ FNV(LNV),UNV(LNV),PNV(6,LNV),ZIA(LEM),UCSELF, * ALPHA,UCSLFI(LEM), MODE, NVN, NVEC(3,LNV) REAL *8 FNV,UNV,PNV,ZIA,UCSELF,ALPHA,UCSLFI COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME COMMON /CONSTS/ PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL REAL *8 PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL C INTEGER INP(51) C ANM = 3.0 IF (ABS(MODE).GE.3 .AND. ABS(MODE).LE.9) ANM = MODE C IF (ALPHA.GT.0.9 .OR. ALPHA.LT.14.9) THEN ICUT = ALPHA RCUT(2) = (LSR-1.0)/100.0 ELSE ICUT = 0 IF (RCUT(2).LT.0.01 .OR. RCUT(2).GT.(LSR-1.0)/100.0) THEN RCUT(2) = (LSR-1.0)/100.0 END IF END IF NRCUT(2) = INT(RCUT(2) * 100.0 + 1.01) RCUT(1) = RCUT(1) C C *** LRO-II C NPAIR = NCOMPO * (NCOMPO+1) / 2 DO 110 I = 1, NCOMPO AKFI(I) = 0.0 110 CONTINUE C ------------------------------------------------ Fermi wave number AKFI(1) = (3.0 * PI**2 * NION(1) / VOL)**(1.0/3.0) C C U = KB * [ (A/r)**n * cos(2*kf*r - B) + exp(C - D*r) ] C DO 350 I = 50, LSR E0(I) = 0.0 F0(I) = 0.0 R = REAL(I) * 0.01 DO 340 J = 1, NPAIR E1(I,J) = 0.0 F1(I,J) = 0.0 IF (ABS(AIO(J)).GT.1.0E-10) THEN ARN = (AIO(J) / R)**ANM PHI = 2.0 * AKFI(J) * R - BIO(J) EFG = EXP(CIO(J) - DIO(J) * R) C C E0(I,J) = AKB * ARN * COS(PHI) E1(I,J) = AKB * ARN * COS(PHI) + AKB * EFG C FF1 = (- ANM * COS(PHI) / R * - 2.0 * AKFI(J) * SIN(PHI)) * ARN FF2 = - DIO(J) * EFG F1(I,J) = - (FF1 + FF2) * AKB * 1.0E8 / R END IF 340 CONTINUE 350 CONTINUE C ------------------------------ CORRECTION FOR TERMINATION AT RCUTL ECORR = 0.0 VCORR = 0.0 IF (ICUT.EQ.0) THEN DRVN2 = NION(1) / VOL * 4.0 * PI * 0.02 AKF2 = 2.0 * AKFI(1) DO 400 RI = RCUT(2), 1999.0, 0.02 R = RI + 0.01 F = (1999.0 - R) / (1999.0 - RCUT(2)) IF (ANM.GT.3.1) F = 1.0 VRN = R**2 * DRVN2 ARN = (AIO(1) / R)**ANM PHI = AKF2*R - BIO(1) ECORR = ECORR + COS(PHI) * ARN * VRN C VCORR = VCORR - * (- ANM*COS(PHI)/R * - AKF2*SIN(PHI)*F ) * R * ARN * VRN 400 CONTINUE ECORR = ECORR * NION(1) * AKB * FJMOL / 2.0 VCORR = VCORR * NION(1) / 2.0 * AKB * 1.0D-10 * / (VOL*1.0D-24) / 3.0 ELSE DO 450 J = 1, NCOMPO IF (ABS(AIO(J)).GT.1.0E-10) THEN NP = 0 EE0 = E1(200,J) DO 440 I = 201, NRCUT(2) EE = E1(I,J) IF (EE0*EE.LE.0.0) THEN NP = NP + 1 INP(NP) = I IF (NP.GE.50) GO TO 490 END IF EE0 = EE 440 CONTINUE 490 IF (ICUT.GT.NP) ICUT = NP NRCUT(2) = INP(ICUT) RCUT(2) = NRCUT(2) * 0.01 NRCUT(1) = NRCUT(2) RCUT(1) = RCUT(2) ANP = INP(ICUT) - INP(ICUT-1) + 1 DO 460 I = INP(ICUT-1), INP(ICUT) E1(I,J) = E1(I,J) * (I-INP(ICUT-1))/ANP F1(I,J) = F1(I,J) * (I-INP(ICUT-1))/ANP 460 CONTINUE IF (IPR.EQ.1) THEN DO 470 I = 1, NP JNP = INP(I) 470 CONTINUE END IF END IF 450 CONTINUE END IF C IF (IPR.EQ.1) THEN WRITE (*,1001) RCUT(1),AKFI(1),ECORR,VCORR 1001 FORMAT (10X,'RCUT=',F8.4,' KF=',F6.4,' Ecorr=',F6.3, * ' Pcorr=',F6.3) END IF C C DO 160 I = 100, NCUT, 10 C WRITE (16,*) I,E0(I,1)+E1(I,1),F1(I,1) C 160 CONTINUE C WRITE (*,*) 375,E1(375,1),F1(375,1) RETURN END C C C ======= C================================================================ CLEARS SUBROUTINE CLEARS PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C C --------------------------------- Clear variables for accumulation C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES(3),PPXYZ(7),FJMOL, * T000,T050, IAXTGR, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME COMMON /VALUES/ TVAL(LVA),TVALL(LVA),VALMAX(LVA),VAL0(LVA), * SVAL(LVA),SVALL(LVA),VALMIN(LVA), * VAL(LVA),AVA(LVA,L50), NAV,NAVT REAL *8 TVAL,SVAL,TVALL,SVALL,VALMAX,VALMIN,VAL0,VAL,AVA COMMON /RADIAL/ NRDF(LTB,LEE),IPRDF(2) INTEGER *4 NRDF COMMON /GEOMET/ DTO(2),AVTHT(12),MBR(8,8,2),NRG(9,2),ITBR(121,12), * RTO(2),SVTHT(12),NBR(8,8,2),MEB(9,2), NTT(121,12), * NTO(2),NVTHT(12),ANGL(3,12),TTAB(LST), NTBL, * ANCN(7,2) COMMON /ACOORD/ NPT, BOXO(6),NIU(LAA),P0C(3,LAT),NSYM,ISYM(LNI), * NPTP,NBOX(3),JON(LAT),PPC(3,LAT),MATM, * RS(3,3,96),PPS(3,LAT),IHEX COMMON /VECTOR/ FNV(LNV),UNV(LNV),PNV(6,LNV),ZIA(LEM),UCSELF, * ALPHA,UCSLFI(LEM), MODE, NVN, NVEC(3,LNV) REAL *8 FNV,UNV,PNV,ZIA,UCSELF,ALPHA,UCSLFI C INTEGER *4 IYEAR,IMONTH,IDAY, IHOUR,IMINUT, ISECND, I100TH C CALL KCLOCK (IYEAR,IMONTH,IDAY, IHOUR,IMINUT,ISECND,I100TH) NN = IRECRD(2)/IRECRD(3) MM = MOD(NRECRD(1)/IRECRD(3), NN) JM = 2 IF (RUNOPT(3).EQ.'ECONOMY ') JM = 10 IM = 1 IF (RUNOPT(3).EQ.'ECONOMY ') IM = 0 IF (NRECRD(3).EQ.1) GOTO 10 IF (NRECRD(3).EQ.IM.OR.MOD(MM,JM).EQ.0) GO TO 10 IF (RUNOPT(3).NE.'ECONOMY ') GO TO 11 IF (NRECRD(3).NE.IM.AND.MOD(MM,JM).NE.0) GO TO 12 10 WRITE (16,2450) NJOB,TITLE,TEMP, IHOUR,IMINUT,ISECND, * IYEAR,IMONTH,IDAY 11 WRITE (16,2452) (ATOM(I),I=1,4) C 2450 FORMAT (/'<<<<<<',I4,'-',I2,' <<<< ',15A4,' >>>> T=',F7.1, * ' (at ',I2,':',I2,':',I2, * ' on ',I2,'/',I2,'/',I2,') >>>>>>') 2452 FORMAT(/' Step ',4('T:',A2,1X),'Temp P/GPa (Pxx, Pyy, ', * 'Pzz, Pxy, Pxz, Pyz) U:Coulomb Short ', * '3-body Kin. Total Density') C 12 IF(MOD(NRECRD(1),IRECRD(3)).NE.1) RETURN C DO 20 I = 1, LVA TVALL(I) = 0.0 SVALL(I) = 0.0 20 CONTINUE C IF (MOD(NRECRD(1),IRECRD(2)).NE.1) RETURN DO 30 I = 1, NTION AU(I) = 0.0 30 CONTINUE C IF (NRECRD(2).GT.0.AND.RUNOPT(4).EQ.'ACCUM ') RETURN NRECRD(2) = 0 NTBL = 0 DO 40 J = 1, LEE DO 40 I = 1, LTB NRDF(I,J) = 0 40 CONTINUE DO 75 I = 1, 12 DO 70 J = 1, 3 ANGL(J,I) = 0.0 70 CONTINUE DO 72 J = 1, 121 ITBR(J,I) = 0 72 CONTINUE 75 CONTINUE DO 90 K = 1, 2 DO 80 I = 1, 8 DO 80 J = 1, 8 MBR(J,I,K) = 0 80 CONTINUE DO 85 I = 1, 9 NRG(I,K) = 0 85 CONTINUE 90 CONTINUE DO 50 I = 1,NPT DO 50 J = 1, 3 PPC(J,I) = 0.0 PPS(J,I) = 0.0 50 CONTINUE do 60 i = 1, 7 ancn(i,1) = 0.0 ancn(i,2) = 0.0 60 continue RETURN END C C C ======== C================================================================ NEWTON SUBROUTINE NEWTON PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C C ----------------------------------------- Heart of MD calculations C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES(3),PPXYZ(7),FJMOL, * T000,T050, IAXTGR, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /BOXCNG/ BTAGET, BCNGR, ICAXIS COMMON /CARTES/ H(3,3),HINV(3,3),FTOQ(3,3),RBOX(6), * G(3,3),GINV(3,3),TRANSX(8),TRANSY(8),TRANSZ(8) CT * ,Q(3,LNI),Q0(3,LNI) REAL *8 H,HINV,G,GINV,FTOQ,RBOX,TRANSX,TRANSY,TRANSZ COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME COMMON /PARAMT/ AIO(LEM),BIO(LEM),CIO(LEM),DIO(LEM),ZIO(LEM), * AIJ(LEF),BIJ(LEF),CIJ(LEF),DIJ(LEF),D4IJ(LEF), * PLIJ(LEF),RSWTCH(LEF),ZIJ(LEF), D7IJ(LEF), * ECORR,VCORR, WIO(LEM), TWEGHT, AKFI(LEM), * ANG3BP(L3P), R3BLIM(2,L3P), * FK3BP(L3P), R3BGRD(2,L3P), R3lim(2,l3p),r3limax, * I3BP(3,L3P), N3BP COMMON /TABLES/ F1(LSR,LEE),E1(LSR,LEE),F0(LTB),E0(LTB) REAL *8 F1,E1,F0,E0 COMMON /VECTOR/ FNV(LNV),UNV(LNV),PNV(6,LNV),ZIA(LEM),UCSELF, * ALPHA,UCSLFI(LEM), MODE, NVN, NVEC(3,LNV) REAL *8 FNV,UNV,PNV,ZIA,UCSELF,ALPHA,UCSLFI COMMON /VALUES/ TVAL(LVA),TVALL(LVA),VALMAX(LVA),VAL0(LVA), * SVAL(LVA),SVALL(LVA),VALMIN(LVA), * VAL(LVA),AVA(LVA,L50), NAV,NAVT REAL *8 TVAL,SVAL,TVALL,SVALL,VALMAX,VALMIN,VAL0,VAL,AVA COMMON /RADIAL/ NRDF(LTB,LEE),IPRDF(2) INTEGER *4 NRDF COMMON /GEOMET/ DTO(2),AVTHT(12),MBR(8,8,2),NRG(9,2),ITBR(121,12), * RTO(2),SVTHT(12),NBR(8,8,2),MEB(9,2), NTT(121,12), * NTO(2),NVTHT(12),ANGL(3,12),TTAB(LST), NTBL, * ANCN(7,2) COMMON /ACOORD/ NPT, BOXO(6),NIU(LAA),P0C(3,LAT),NSYM,ISYM(LNI), * NPTP,NBOX(3),JON(LAT),PPC(3,LAT),MATM, * RS(3,3,96),PPS(3,LAT),IHEX COMMON /FORCES/ FX(LNI),FY(LNI),FZ(LNI) REAL *8 FX,FY,FZ COMMON /WORK01/ PX(LNI),PY(LNI),PZ(LNI) REAL *8 PX,PY,PZ COMMON /WORK02/ UUII(LNI),ZII(LNI),ZICOS(LNI),ZISIN(LNI) REAL *8 ZICOS, ZISIN COMMON /QUANCO/ Q1U1(LSR,LEE),Q2U1(LSR,LEE), * TQCE,QCEE,QCIT,QCEF,TEMPQH,TEMPQQ REAL *8 TQCE,QCEE,QCIT,QCEF COMMON /MOLECU/ ZMOLE(2), DMOLE(4,LNI), DINTRA(2), * NDMOLE, IDMOLE(3,LNI), IATOM2(2), MOLstart(2), * NMOLE, IMOLE(38,LNI), MMOLE(LNI), MOLend(2) real *8 zmole,dmole COMMON /OUTERF/ EFD(3), EFREQ, GFD(3), fconvc, MEFD REAL *8 EFD, EFREQ, GFD common /EXCLUS/ REXCL, Fexcl, iaex, iextype common /REMOVE/ RMZL,RMZH,RMVZ COMMON /CONSTS/ PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL REAL *8 PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL C REAL *8 PXYZ(7), Pbox(6) REAL *8 VIRLSR, ABOX1, V1I, PXI, VAVB(6),PJI,PCT(6), * AMV2, ABOX2, V2I, PYI, CENTRE, WGIO, * TMV2, ABOX3, V3I, PZI, CENTRP, FV,FVI,V2 REAL *8 PRSTC2(6),DIPOLE(3), VC(3,LNI), fex(3) C DO 20 N = 1, N3BP AV3BP(1,N) = 0.0 AV3BP(2,N) = 0.0 20 CONTINUE C if (runopt(30).eq.'REMOVE ') then do i=1, ntion zz=p(3,i) if (zz.ge.rmzl .and. zz.le.rmzh) then if (v(3,i)*rmvz .ge. 0.0 ) then iond(i) = 0 v(1,i) = 0.0 v(2,i) = 0.0 v(3,i) = 0.0 end if end if end do end if C DO 80 IO = 1, NCOMPO IF (NION(IO).LE.0) GO TO 80 DO 60 I = IONS(1,IO), IONS(2,IO) UI(I) = 0.0 FX(I) = 0.0D0 FY(I) = 0.0D0 FZ(I) = 0.0D0 DO 50 J = 1, 3 IF (P(J,I).LT.0.0D0.OR.P(J,I).GE.1.0D0) THEN PJI = -SIGN(1.0D0,P(J,I)) P0(J,I) = P0(J,I) + PJI P(J,I) = P(J,I) + PJI END IF 50 CONTINUE PX(I) = P(1,I) PY(I) = P(2,I) PZ(I) = P(3,I) ZII(I) = ZIO(IO) IF (IOND(I).EQ.0) ZII(I) = 0.0 60 CONTINUE 80 CONTINUE c if (runopt(23).eq.'DIATOMIC ') call Center_of_Diatomic_Molecule c DO 90 I = 1, LVA VAL(I) = 0.0D0 90 CONTINUE NRECRD(2) = NRECRD(2) + 1 IF (MOD(NRECRD(1)-1,NTSTEP).EQ.0) THEN TINT = 0.0 QCEE = 0.0D0 QCEF = 0.0D0 END IF C --------------------------------- Coulomb and Short range (2-body) C and 3-body term CALL EWALDS (VIRLSR, PRSTC2) C -------------------------------------------------- Electric field IF (RUNOPT(20).EQ.'ELEC.FIELD') CALL ELECFD C --------------------------------------------------- Gravity field IF (RUNOPT(21).EQ.'GRAV.FIELD') CALL GRAVFD C -------------------------------------------------- Convection flow if (RUNOPT(25).EQ.'CONVECTION') then do 110 i = 1, ntion if (px(i).lt.0.05 .or. px(i).gt.0.95) then fy(i) = fy(i) - abs(fy(i)) * fconvc else if (px(i).gt.0.45. and. px(i).lt.0.55) then fy(i) = fy(i) + abs(fy(i)) * fconvc end if 110 continue end if C ----------------------------------------------- Exclusion of atoms if (runopt(27).eq.'EXCLUSION ') then c write (6,*) iextype,iaex,rexcl,fexcl ia1 = 1 ia2 = 2 if (iaex.eq.2) then ia1 = 1 ia2 = 3 end if if (iaex.eq.1) then ia1 = 2 ia2 = 3 end if if (iextype.eq.1) then c write (6,*) iextype, iaex, rexcl do 120 i = 1, ntion xx = (p(ia1,i)-0.5)*BOX(ia1) yy = (p(ia2,i)-0.5)*box(ia2) rr = sqrt(xx**2 + yy**2) if (rexcl.gt.0.0 .and. rr.le.rexcl) then fex(1) = fx(i) fex(2) = fy(i) fex(3) = fz(i) xxe = xx / sqrt(xx**2+yy**2) yye = yy / sqrt(xx**2+yy**2) fex(ia1) = fex(ia1) + xxe*Fexcl fex(ia2) = fex(ia2) + yye*Fexcl fx(i) = fex(1) fy(i) = fex(2) fz(i) = fex(3) end if if (rexcl.lt.0.0 .and. rr.gt.abs(rexcl)) then fex(1) = fx(i) fex(2) = fy(i) fex(3) = fz(i) xxe = -xx / sqrt(xx**2+yy**2) yye = -yy / sqrt(xx**2+yy**2) fex(ia1) = fex(ia1) + xxe*Fexcl fex(ia2) = fex(ia2) + yye*Fexcl fx(i) = fex(1) fy(i) = fex(2) fz(i) = fex(3) end if 120 continue else if (iextype.eq.2) then do 130 i = 1, ntion rr = (p(iaex,i)-0.5)*BOX(ia1) if (rr.le.rexcl) then fex(1) = fx(i) fex(2) = fy(i) fex(3) = fz(i) fex(iaex) = fex(iaex) + sign(1.0,rr)*Fexcl fx(i) = fex(1) fy(i) = fex(2) fz(i) = fex(3) end if 130 continue else if (iextype.eq.3) then else if (iextype.eq.5) then c write (6,*) 'HONEYCOMB',iaex,iextype, rexcl,fexcl do 150 i = 1, ntion c (0.0, 0.0) xx = p(ia1,i)+0.5 yy = p(ia2,i)+0.5 if (xx.gt.1.0) xx = xx - 1.0 if (yy.gt.1.0) yy = yy - 1.0 xx = (xx-0.5)*BOX(ia1) yy = (yy-0.5)*box(ia2) rr = sqrt(xx**2 + yy**2) if (rr.le.rexcl) then fex(1) = fx(i) fex(2) = fy(i) fex(3) = fz(i) xxe = xx / rr yye = yy / rr fex(ia1) = fex(ia1) + xxe*Fexcl fex(ia2) = fex(ia2) + yye*Fexcl fx(i) = fex(1) fy(i) = fex(2) fz(i) = fex(3) end if c (0.5, 0.5) xx = (p(ia1,i)-0.5)*BOX(ia1) yy = (p(ia2,i)-0.5)*box(ia2) rr = sqrt(xx**2 + yy**2) if (rr.le.rexcl) then fex(1) = fx(i) fex(2) = fy(i) fex(3) = fz(i) xxe = xx / rr yye = yy / rr fex(ia1) = fex(ia1) + xxe*Fexcl fex(ia2) = fex(ia2) + yye*Fexcl fx(i) = fex(1) fy(i) = fex(2) fz(i) = fex(3) end if 150 continue end if end if C ----------------------------------------------------- Wall at z= 0 if (runopt(28).eq.'WALL ') call WALL C C +----------------------------------------------------------------I C : Contents of VAL(1) - VAL(LVA) variables : C : No. : Meanings : C : 1 : Temperature / K : C : 2 : Pressure / GPa : C : 3-8 : Components of pressure tensor / GPa : C : : (xx, yy, zz, xy, xz, yz) : C : 9 : Coulomb energy / kJ.mol-1 : C : 10 : Short range energy / kJ.mol-1 : C : : (repulsion, van der Waals, Morse, etc.) : C : 11 : Three body potential energy / kJ.mol-1 : C : 12 : Total potential energy (9+10+11) / kJ.mol-1 : C : 13 : Kinetic energy / kJ.mol-1 : C : 14 : Total internal energy (9+10+11+13) / kJ.mol-1 : C : 15 : PV (pressure x volume) / kJ.mol-1 : C : 16 : Enthalpy (14+15) / kJ.mol-1 : C : 17 : Density / g.cm-3 : C : 18 : Molar volume / cm3.mol-1 : C : 19-21 : Basic cell parameters: A, B, C /A : C : : (Crystal unit cell (a,b,c) in XD) : C : 22-24 : cos(alpha), cos(beta), cos(gamma) : C : 25-34 : Temperatures of ion species (10 components) / K : C : 35-44 : Mean square displacement (10 components) / A^2 : C +----------------------------------------------------------------I C C -------------------------------------- Dipole moment of basic cell C (2*Pi/3L**3)* [Sum of qi*ri] IF (RUNOPT(14).EQ.'DIPOLE ') THEN DIPOLE(1) = 0.0D0 DIPOLE(2) = 0.0D0 DIPOLE(3) = 0.0D0 DO 220 IO = 1, NCOMPO IF (NION(IO).LE.0) GO TO 220 DO 210 I = IONS(1,IO), IONS(2,IO) PXI = PX(I) PYI = PY(I) PZI = PZ(I) IF (P0(1,I).GT.0.999999) PXI = PXI - 1.0 IF (P0(2,I).GT.0.999999) PYI = PYI - 1.0 IF (P0(3,I).GT.0.999999) PZI = PZI - 1.0 DIPOLE(1) = DIPOLE(1) + ZIO(IO)*PXI*BOX(1) DIPOLE(2) = DIPOLE(2) + ZIO(IO)*PYI*BOX(2) DIPOLE(3) = DIPOLE(3) + ZIO(IO)*PZI*BOX(3) 210 CONTINUE 220 CONTINUE DO 250 IO = 1, NCOMPO IF (NION(IO).LE.0) GO TO 250 DO 240 I = IONS(1,IO), IONS(2,IO) FX(I) = FX(I) - ZIO(IO) * DIPOLE(1) * 4.0D0 * PI * / VOL * ELC**2 * 1.0D16 FY(I) = FY(I) - ZIO(IO) * DIPOLE(2) * 4.0D0 * PI * / VOL * ELC**2 * 1.0D16 FZ(I) = FZ(I) - ZIO(IO) * DIPOLE(3) * 4.0D0 * PI * / VOL * ELC**2 * 1.0D16 240 CONTINUE 250 CONTINUE DIPM2 = (DIPOLE(1)**2 + DIPOLE(2)**2 + DIPOLE(3)**2) * * 2.0D0 * PI / (3.0D0 * VOL) * ELC**2 * * 1.0D8 * FJMOL C WRITE (*,*) DIPM2 END IF C =============================== Integration of equations of motion ABOX1 = 1.0D0 / BOX(1) ABOX2 = 1.0D0 / BOX(2) ABOX3 = 1.0D0 / BOX(3) X0 = (0.5-0.0) *(0.5-1.0)/(((-1.0)-0.0)*((-1.0)-1.0)) X1 = (0.5-(-1.0))*(0.5-1.0)/((0.0-(-1.0))*(0.0-1.0)) X2 = (0.5-(-1.0))*(0.5-0.0)/((1.0-(-1.0))*(1.0-0.0)) C IF (RUNOPT(5).EQ.'T NOSE ') GO TO 400 C ------------------------------------------- Scaling and Andersen's DO 330 IO = 1, NCOMPO IF (NION(IO).LE.0) GO TO 330 IF (WIO(IO).LT.0.00001) GO TO 330 IS1 = IONS(1,IO) IS2 = IONS(2,IO) WGIO = DBLE(DTIME)**2 / (WIO(IO)/ANA) * 1.0D8 DO 310 I = IS1, IS2 CT CALL PTOXYZ (I) IF (IOND(I).EQ.0) THEN V(1,I) = 0.0 V(2,I) = 0.0 V(3,I) = 0.0 GO TO 310 END IF IF (RUNOPT(6).EQ.'P ANDERSEN' .OR. * RUNOPT(6).EQ.'P ANDERS-C') THEN C ------------------------- Andersen's algorithm V1I = V(1,I) + FX(I)*WGIO - VBOX(1)*V(1,I) V2I = V(2,I) + FY(I)*WGIO - VBOX(2)*V(2,I) V3I = V(3,I) + FZ(I)*WGIO - VBOX(3)*V(3,I) ELSE C ----------------------------- Verlet algorithm V1I = V(1,I) + FX(I)*WGIO V2I = V(2,I) + FY(I)*WGIO V3I = V(3,I) + FZ(I)*WGIO END IF IF (IION(IO).GE.0) THEN P(1,I) = P(1,I) + V1I * ABOX1 P(2,I) = P(2,I) + V2I * ABOX2 P(3,I) = P(3,I) + V3I * ABOX3 CT Q(1,I) = Q(1,I) + V1I CT Q(2,I) = Q(2,I) + V2I CT Q(3,I) = Q(3,I) + V3I ELSE V1I = 0.0D0 V2I = 0.0D0 V3I = 0.0D0 END IF C ------------------ Interpolation for present velocity C V1I:+(1/2)t VC(1,I):0 V(1,I):-(1/2)t VP(1,I):-(3/2)t IF (NRECRD(3).EQ.1) THEN VP(1,I) = V(1,I) - FX(I)*WGIO VP(2,I) = V(2,I) - FY(I)*WGIO VP(3,I) = V(3,I) - FZ(I)*WGIO END IF VC(1,I) = VP(1,I)*X0 + V(1,I)*X1 + V1I*X2 VC(2,I) = VP(2,I)*X0 + V(2,I)*X1 + V2I*X2 VC(3,I) = VP(3,I)*X0 + V(3,I)*X1 + V3I*X2 VP(1,I) = V(1,I) VP(2,I) = V(2,I) VP(3,I) = V(3,I) V(1,I) = V1I V(2,I) = V2I V(3,I) = V3I 310 CONTINUE 330 CONTINUE GO TO 500 C ------------------------------------------------ Nose's thermostat 400 A3NKBT = 3.0D0*NTION*AKB*TEMP TMV2 = 0.0D0 DO 460 IO = 1, NCOMPO IF (NION(IO).LE.0) GO TO 460 IF (WIO(IO).LT.0.00001) GO TO 460 IS1 = IONS(1,IO) IS2 = IONS(2,IO) AMV2 = 0.0D0 DO 450 I = IS1, IS2 AMV2 = AMV2 + V(1,I)**2 + V(2,I)**2 + V(3,I)**2 450 CONTINUE TMV2 = TMV2 + AMV2 *1.0D-16*(WIO(IO)/ANA)/(DTIME**2) 460 CONTINUE C STEMP : g.cm**2, erg.s**2 VSTEMP = VSTEMP + (TMV2 - A3NKBT) / STEMP * 1.0D16 * DTIME DO 490 IO = 1, NCOMPO IF (NION(IO).LE.0) GO TO 490 IF (WIO(IO).LT.0.00001) GO TO 490 WGIO = DBLE(DTIME)**2 / (WIO(IO)/ANA) * 1.0D8 IS1 = IONS(1,IO) IS2 = IONS(2,IO) DO 480 I = IS1, IS2 IF (RUNOPT(6).EQ.'P ANDERSEN' .OR. * RUNOPT(6).EQ.'P ANDERS-C' ) THEN C ------------------------- Andersen's algorithm V1I = V(1,I) + FX(I)*WGIO - VSTEMP *V(1,I) * - VBOX(1)*V(1,I) V2I = V(2,I) + FY(I)*WGIO - VSTEMP *V(2,I) * - VBOX(2)*V(2,I) V3I = V(3,I) + FZ(I)*WGIO - VSTEMP *V(3,I) * - VBOX(3)*V(3,I) ELSE V1I = V(1,I) + FX(I)*WGIO - VSTEMP*V(1,I) V2I = V(2,I) + FY(I)*WGIO - VSTEMP*V(2,I) V3I = V(3,I) + FZ(I)*WGIO - VSTEMP*V(3,I) END IF IF (IION(IO).GE.0) THEN P(1,I) = P(1,I) + V1I * ABOX1 P(2,I) = P(2,I) + V2I * ABOX2 P(3,I) = P(3,I) + V3I * ABOX3 ELSE V1I = 0.0D0 V2I = 0.0D0 V3I = 0.0D0 END IF C ------------------ Interpolation for present velocity IF (NRECRD(3).EQ.1) THEN VC(1,I) = (V(1,I) + V1I) / 2.0D0 VC(2,I) = (V(2,I) + V2I) / 2.0D0 VC(3,I) = (V(3,I) + V3I) / 2.0D0 ELSE VC(1,I) = VP(1,I)*X0 + V(1,I)*X1 + V1I*X2 VC(2,I) = VP(2,I)*X0 + V(2,I)*X1 + V2I*X2 VC(3,I) = VP(3,I)*X0 + V(3,I)*X1 + V3I*X2 END IF VP(1,I) = V(1,I) VP(2,I) = V(2,I) VP(3,I) = V(3,I) V(1,I) = V1I V(2,I) = V2I V(3,I) = V3I 480 CONTINUE 490 CONTINUE C WRITE (*,*) TMV2, A3NKBT, VSTEMP C ================================================================== C 500 DO 510 I = 1, 6 PCT(I) = 0.0D0 510 CONTINUE DO 580 IO = 1, NCOMPO DO 530 J = 1, 6 VAVB(J) = 0.0D0 530 CONTINUE IF (NION(IO).LE.0) GO TO 580 IF (WIO(IO).LT.0.00001) GO TO 580 IS1 = IONS(1,IO) IS2 = IONS(2,IO) VALIO2 = 0.0D0 DO 560 I = IS1, IS2 CT CALL PTOXYZ (I) IF (IOND(I).EQ.0) THEN UI(I) = 0.0 GO TO 560 END IF UI(I) = UI(I) + ZIA(IO) AU(I) = AU(I) + UI(I) C --------------------- Thermal part of pressure tensor VAVB(1) = VAVB(1) + VC(1,I)**2 VAVB(2) = VAVB(2) + VC(2,I)**2 VAVB(3) = VAVB(3) + VC(3,I)**2 VAVB(4) = VAVB(4) + VC(1,I) * VC(2,I) VAVB(5) = VAVB(5) + VC(1,I) * VC(3,I) VAVB(6) = VAVB(6) + VC(2,I) * VC(3,I) C ------------------------------------------ For m.s.d. VALIO2 = VALIO2 + ((P(1,I)-P0(1,I))*BOX(1))**2 * + ((P(2,I)-P0(2,I))*BOX(2))**2 * + ((P(3,I)-P0(3,I))*BOX(3))**2 CT VALIO2 = VALIO2 + (Q(1,I)-Q0(1,I))**2 CT * + (Q(2,I)-Q0(2,I))**2 CT * + (Q(3,I)-Q0(3,I))**2 560 CONTINUE C --------------------- Sum of (1/2)mv2 of i-th ion species AMV2 = (VAVB(1)+VAVB(2)+VAVB(3))*1.0D-16 * * (WIO(IO)/ANA) / (2.0D0 * DTIME**2) if (iion(io).eq.-1) AMV2 = (1.5D0 * REAL(NIOND(IO))*AKB) * * temp VAL(13) = VAL(13) + AMV2 VAL(24+IO) = AMV2 / (1.5D0 * REAL(NIOND(IO)) *AKB) DO 570 J = 1, 6 PCT(J) = PCT(J) + (VAVB(J)*1.0D-16)*(WIO(IO)/ANA) * / (DTIME**2) 570 CONTINUE C -------------------------------------------------- M.s.d. VAL(34+IO) = VALIO2 / REAL(NIOND(IO)) 580 CONTINUE C DO 690 IO = 1, NCOMPO IF (NION(IO).LE.0) GO TO 690 DO 680 I = IONS(1,IO), IONS(2,IO) DO 670 J = 1, 3 IF (P(J,I).LT.0.0.OR.P(J,I).GE.1.0) THEN PJI = -SIGN(1.0D0,P(J,I)) P0(J,I) = P0(J,I) + PJI P(J,I) = P(J,I) + PJI END IF 670 CONTINUE 680 CONTINUE 690 CONTINUE c C ----------------------------------------- Temperature and pressure VAL(1) = VAL(13) / (1.5D0 * REAL(NTION-NTIOND) * AKB) C ----------------------------------------------- Quantum correction IF (RUNOPT(12).EQ.'QUANTUM ') THEN CALL QUANTM END IF C ------------------------------------------------------------------ TMV2 = 2.0D0 * VAL(13) TINT = TINT + VAL(1) VAL(9) = UCSELF + VAL(9) C write (*,*) ucself,val(9) VIRLSR = VIRLSR * 1.0D-8 + VCORR VAL(2) = ( VAL(13)*2.0D0 + VIRLSR + VAL(9) ) * / (3.0D0*VOL*1.0D-24)*1.0D-10 VAL(3) = VAL(3) + VCORR/3.0 VAL(4) = VAL(4) + VCORR/3.0 VAL(5) = VAL(5) + VCORR/3.0 PXYZ(1) = VAL(2) DO 710 J = 1, 6 VAL(J+2) = (PCT(J) + VAL(J+2)) * / (VOL*1.0D-24) * 1.0D-10 PXYZ(J+1) = VAL(J+2) PRSTC2(J) = PRSTC2(J) / (VOL*1.0D-24) * 1.0D-10 710 CONTINUE C --------------------------------------------------------- Energies VAL(10) = VAL(10) + ECORR VAL(12) = VAL(9) + VAL(10) + VAL(11) DO 730 I = 9, 13 VAL(I) = VAL(I) * FJMOL 730 CONTINUE VAL(14) = VAL(12) + VAL(13) ASPRES = (SPRES(1) + SPRES(2) + SPRES(3)) / 3.0 VAL(15) = ASPRES * VOL * FJMOL*1.0D-11 *1.0D-3 VAL(16) = VAL(14) + VAL(15) C ------------------------------------------------- Pressure control do i=1, 6 pbox(i) = box(i) end do C -------------------------------------- Pressure control by scaling IF (RUNOPT(6).EQ.'P SCALING ') CALL SCCELL (PXYZ) C ------------------------------------- Pressure control by Andersen IF (RUNOPT(6).EQ.'P ANDERSEN') THEN DPRES = VAL(2) - (VAL(3) + VAL(4) + VAL(5))/3.0 PRESX = VAL(3) + DPRES PRESY = VAL(4) + DPRES PRESZ = VAL(5) + DPRES VOLS = 1.0D-1*1.0D3*VOL*DTIME**2 C WRITE(*,*) 'VOLS=',VOLS VBOX(1) = VBOX(1) + VOLS*(PRESX-SPRES(1))*ABOX1/VIRM(1) VBOX(2) = VBOX(2) + VOLS*(PRESY-SPRES(2))*ABOX2/VIRM(2) VBOX(3) = VBOX(3) + VOLS*(PRESZ-SPRES(3))*ABOX3/VIRM(3) C WRITE(*,*) CELLV BOX(1) = BOX(1) + VBOX(1) BOX(2) = BOX(2) + VBOX(2) BOX(3) = BOX(3) + VBOX(3) DO 750 J = 1, 3 H(J,1) = H(J,1) * BOX(1) * ABOX1 H(J,2) = H(J,2) * BOX(2) * ABOX2 H(J,3) = H(J,3) * BOX(3) * ABOX3 750 CONTINUE CALL TABLER (0) END IF C --------------------------------------------------- Cubic Andersen IF (RUNOPT(6).EQ.'P ANDERS-C') THEN VOLS = 1.0D-1*1.0D3*VOL*DTIME**2 C WRITE(*,*) 'VOLS=',VOLS VBOX(1) = VBOX(1) + VOLS*(VAL(2)-SPRES(1))*ABOX1/VIRM(1) VBOX(2) = VBOX(1) VBOX(3) = VBOX(1) C WRITE(*,*) CELLV BOX(1) = BOX(1) + VBOX(1) BOX(2) = BOX(1) BOX(3) = BOX(1) DO 755 J = 1, 3 H(J,1) = H(J,1) * BOX(1) * ABOX1 H(J,2) = H(J,2) * BOX(2) * ABOX2 H(J,3) = H(J,3) * BOX(3) * ABOX3 755 CONTINUE CALL TABLER (0) END IF C ------------------------------------------------------- Cubic cell if (RUNOPT(24).EQ.'CUBE ') then VVVV = box(1) * box(2) * box(3) abox = (box(1) + box(2) + box(3)) / 3.0 box(1) = box(1) - (box(1)-abox)*0.0001 box(2) = box(2) - (box(2)-abox)*0.0001 box(3) = box(3) - (box(3)-abox)*0.0001 ffff = (vvvv / (box(1)*box(2)*box(3)))**(1.0/3.0) box(1) = box(1) * ffff box(2) = box(2) * ffff box(3) = box(3) * ffff call tabler (0) end if if (RUNOPT(24).EQ.'CUBE-F ') then VVVV = box(1) * box(2) * box(3) abox = VVVV**(1.0/3.0) box(1) = abox box(2) = abox box(3) = abox end if C ---------------------------------------------- Chage box with time if (RUNOPT(7).EQ.'V CHANGE ') then box(icaxis) = pbox(icaxis) box(icaxis) = box(icaxis) + BCNGR if (bcngr.gt.0.0 .and. box(icaxis).gt.BTAGET) * box(icaxis)=Btaget if (bcngr.lt.0.0 .and. box(icaxis).lt.BTAGET) * box(icaxis)=Btaget CALL TABLER (0) end if C ------------------------------------------- Bsic cell or unit cell VAL(17) = DENSTY DO 770 I = 1, 6 VAL(I+18) = BOX(I) 770 CONTINUE VAL(18) = VAL(19)*VAL(20)*VAL(21) * ANA * 1.0E-24 / NFORML IF (RUNOPT(17).EQ.'CRYSTAL ') THEN DO 790 I = 1, 3 VAL(I+18) = BOX(I) / NBOX(I) 790 CONTINUE END IF C ---------------------------------------------------- Print results CALL PRINTS (DIPM2) C ------------------------------------- Correction for sum of mv = 0 C (Center of gravity) IF (RUNOPT(21).NE.'GRAV.FIELD' .AND. * RUNOPT(16).NE.'NO(MV=0) ' ) then io1 = 1 io2 = ncompo TWT = TWEGHT if (runopt(16).eq.'AM(MV=0) ') then io1 = Iamv io2 = Iamv nnn = nion(Iamv) if (Namv.gt.0.or.Namv.le.nion(Iamv)) nnn = Namv TWT = wio(Iamv)*nnn end if DO 851 J = 1, 3 CENTRE = 0.0D0 DO 831 IO = Io1, Io2 IF (NION(IO).GT.0) THEN nnn=ions(2,io) if (Iamv.eq.io .and. Namv.gt.0) * nnn = ions(1,io) + Namv-1 DO 821 I = IONS(1,IO), nnn CENTRE = CENTRE + V(J,I)*WIO(IO) 821 CONTINUE END IF 831 CONTINUE CENTRE = CENTRE / TWT CENTRP = CENTRE / BOX(J) c write (6,*) j, centrp, Iamv, Namv,nnn !' grav' DO 841 I = 1, NTION IF (IOND(I).GT.0) THEN V(J,I) = V(J,I) - CENTRE P(J,I) = P(J,I) - CENTRP END IF 841 CONTINUE 851 CONTINUE end if C --------------------------------------------- Temperature control IF (RUNOPT(5).EQ.'T SCALING ') THEN FV = 1.0D0 IF (MOD(NRECRD(1),NTSTEP).EQ.0) THEN TEMP = TEMP + DELTMP IF ((TMPGET-TEMP)*DELTMP.LT.0.0) TEMP = TMPGET FV = SQRT(TEMP/(TINT/DBLE(NTSTEP))) END IF IF (RUNOPT(12).EQ.'QUANTUM ') THEN QCEE = QCEE + QCIT * VAL(1) + TQCE / VAL(1) QCEF = QCEF + QCIT * TEMP + TQCE / TEMP IF (MOD(NRECRD(1),NTSTEP).EQ.0) THEN FV = SQRT(QCEF*1.0D0/QCEE) END IF END IF IF (MODE.LT.0) FV = SQRT(TEMP/TPRE) IF (RUNOPT(5).EQ.'T NO-CNTL.') FV = 1.0D0 C IF (ABS(DELTMP).LE.0.000001) FV = 1.0D0 IF (VAL(1)/TEMP.LT.0.3333D0) FV = SQRT(TEMP/VAL(1)) IF (VAL(1)/TEMP.GT.1.6667D0) FV = SQRT(TEMP/VAL(1)) FV = 1.0D0 + (FV - 1.0D0) * TDUMP IF (ABS(FV-1.0D0).GT.1.0D-7) THEN do 888 io = 1, ncompo if (iion(io).ne.2) then DO 880 I = ions(1,io), ions(2,io) DO 880 J = 1, 3 V(J,I) = V(J,I) * FV 880 continue end if 888 CONTINUE END IF END IF c IF (RUNOPT(5).EQ.'T SCALE-A ') THEN IF (MOD(NRECRD(1),NTSTEP).EQ.0) THEN TEMP = TEMP + DELTMP IF ((TMPGET-TEMP)*DELTMP.LT.0.0) TEMP = TMPGET END IF do 899 io = 1, ncompo FV = 1.0D0 IF (MOD(NRECRD(1),NTSTEP).EQ.0) FV=SQRT(TEMP/VAL(24+IO)) IF (RUNOPT(12).EQ.'QUANTUM ') THEN QCEE = QCEE + QCIT * VAL(24+IO) + TQCE/VAL(24+IO) QCEF = QCEF + QCIT * TEMP + TQCE / TEMP IF (MOD(NRECRD(1),NTSTEP).EQ.0) THEN FV = SQRT(QCEF*1.0D0/QCEE) END IF END IF IF (VAL(24+IO)/TEMP.LT.0.333D0) FV=SQRT(TEMP/VAL(24+IO)) IF (VAL(24+IO)/TEMP.GT.1.667D0) FV=SQRT(TEMP/VAL(24+IO)) FV = 1.0D0 + (FV - 1.0D0) * TDUMP IF (ABS(FV-1.0D0).GT.1.0D-7) THEN if (iion(io).ne.2) then DO 895 I = ions(1,io), ions(2,io) DO 895 J = 1, 3 V(J,I) = V(J,I) * FV 895 CONTINUE end if END IF 899 continue END IF c IF (RUNOPT(5).EQ.'T NOSE ') THEN IF (RUNOPT(12).EQ.'QUANTUM ') THEN QCEE = QCEE + QCIT * VAL(1) + TQCE / VAL(1) QCEF = QCEF + QCIT * TEMP + TQCE / TEMP FV = SQRT(QCEF*1.0D0/QCEE) DO 890 I = 1, NTION DO 890 J = 1, 3 V(J,I) = V(J,I) * FV 890 CONTINUE END IF END IF c IF (RUNOPT(5).EQ.'T GRAD ') THEN ! Temperature gradient in cell kx=iaxtgr at0=0.0 at5=0.0 natg0=0 natg5=0 do IO=1, NCOMPO do i = ions(1,io), ions(2,io) if (p(kx,i).lt.0.01 .or. p(kx,i).gt.0.99) then at0=at0+wio(io)*(v(1,i)**2+v(2,i)**2+v(3,i)**2) natg0=natg0+1 end if if (p(kx,i).gt.0.49 .and. p(kx,i).lt.0.51) then at5=at5+wio(io)*(v(1,i)**2+v(2,i)**2+v(3,i)**2) natg5=natg5+1 end if end do end do TG0= (at0/ANA/DTIME**2)*1.0D-16 / (3.0D0*Natg0*AKB) TG5= (at5/ANA/DTIME**2)*1.0D-16 / (3.0D0*Natg5*AKB) FV0 = 1.0D0 + (sqrt(t000/tg0) - 1.0D0) * TDUMP FV5 = 1.0D0 + (sqrt(t050/tg5) - 1.0D0) * TDUMP do io=1, ncompo do i = ions(1,io), ions(2,io) if (p(kx,i).lt.0.01 .or. p(kx,i).gt.0.99) then v(1,i)=v(1,i)*fv0 v(2,i)=v(2,i)*fv0 v(3,i)=v(3,i)*fv0 end if if (p(kx,i).gt.0.49 .and. p(kx,i).lt.0.51) then v(1,i)=v(1,i)*fv5 v(2,i)=v(2,i)*fv5 v(3,i)=v(3,i)*fv5 end if end do end do if (mod(nrecrd(1),5).eq.0) then write (6,*) ' ##### T(at 0)=',tg0,'(',natg0, * ') T(at 0.5)=',tg5,'(',natg5,') #####' end if END IF C --------------------------- Reduce velocities to prevent explosion if (RUNOPT(5).ne.'T SCALE-A ') then IF (RUNOPT(5).NE.'T NO-CNTL '.AND. * VAL(1).GT.TEMP*2.0D0) THEN IF (VAL(1)-TPRE.GT.1.0D6) GO TO 999 FV = SQRT(TEMP/VAL(1)) DO 950 I = 1, NTION FVI = FV V2 = V(1,I)**2 + V(2,I)**2 + V(3,I)**2 IF (V2.GT.0.2D0) FVI = FV * 0.2D0/V2 DO 940 J = 1, 3 P(J,I) = P(J,I) - (1.0D0 - FVI)*V(J,I) / BOX(J) V(J,I) = V(J,I) * FVI 940 CONTINUE 950 CONTINUE END IF TPRE = VAL(1) end if C C ---------------------------------------- Centering of Atom Cluster if (runopt(15).eq.'CENTERING ') then xcen = 0.0 ycen = 0.0 zcen = 0.0 if (iaxcen.eq.1) then xcen = 1.0 end if if (iaxcen.eq.2) then ycen = 1.0 end if if (iaxcen.eq.3) then zcen = 1.0 end if if (iaxcen.eq.0) then xcen = 1.0 ycen = 1.0 zcen = 1.0 end if do 970 i = 1, ntion v(1,i) = v(1,i) - (p(1,i)-0.5)*0.000005*xcen v(2,i) = v(2,i) - (p(2,i)-0.5)*0.000005*ycen v(3,i) = v(3,i) - (p(3,i)-0.5)*0.000005*zcen 970 continue end if C C CALL XYZTOP RETURN C 999 WRITE (*,9988) VAL(1) 9988 FORMAT (' ***** TEMPERATURE GETS TOO HIGH ',F10.0,'K *****') STOP END C C C ======== C================================================================ PRINTS SUBROUTINE PRINTS (DIPM2) PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES(3),PPXYZ(7),FJMOL, * T000,T050, IAXTGR, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME COMMON /PARAMT/ AIO(LEM),BIO(LEM),CIO(LEM),DIO(LEM),ZIO(LEM), * AIJ(LEF),BIJ(LEF),CIJ(LEF),DIJ(LEF),D4IJ(LEF), * PLIJ(LEF),RSWTCH(LEF),ZIJ(LEF), D7IJ(LEF), * ECORR,VCORR, WIO(LEM), TWEGHT, AKFI(LEM), * ANG3BP(L3P), R3BLIM(2,L3P), * FK3BP(L3P), R3BGRD(2,L3P), R3lim(2,l3p),r3limax, * I3BP(3,L3P), N3BP COMMON /VALUES/ TVAL(LVA),TVALL(LVA),VALMAX(LVA),VAL0(LVA), * SVAL(LVA),SVALL(LVA),VALMIN(LVA), * VAL(LVA),AVA(LVA,L50), NAV,NAVT REAL *8 TVAL,SVAL,TVALL,SVALL,VALMAX,VALMIN,VAL0,VAL,AVA C COMMON /TIMDAT/ KKTIME(7,2) C INTEGER *4 IVAL(LEM) INTEGER *4 IYEAR,IMONTH,IDAY, IHOUR,IMINUT,ISECND,I100TH CHARACTER *40 FMT1(3), FMT11,FMT12 EQUIVALENCE (FMT1(1),FMT11), (FMT1(2),FMT12) C IF (N3BP.GT.0) THEN DO 637 N = 1, N3BP IF (AV3BP(2,N).GT.0.1) AV3BP(1,N)= AV3BP(1,N)/AV3BP(2,N) C WRITE (*,1001) AV3BP(1,N), AV3BP(2,N) 1001 FORMAT (21X,'Average J-I-J angle is ',F6.2,' (',I5,')') 637 CONTINUE END IF C ---------------------------------------------------- Print results CALL KCLOCK (IYEAR,IMONTH,IDAY,IHOUR,IMINUT,ISECND,I100TH) IF (MOD(NRECRD(1),20).EQ.1) WRITE (*,2909) TITLE,IRECRD(1), * NRECRD(1)/10000, IHOUR 2909 FORMAT ('== ',15A4,'(End=',I7,') ==' / * '+',I3,'0K steps ', 59('-'), ' Hour=',I2 / * ' STEP Temp Prss.( Px Py Pz ) ', * 'U(Coul.) U(srt) U(3p) E(total) Density mn:sc') C IF ((KKTIME(5,2).NE.IMINUT .OR. KKTIME(6,2).NE.ISECND) .OR. * IYEAR+IMONTH+IDAY.EQ.0) THEN VAL2 = ABS(VAL(2)) FMT11 = '(1X,I4,I5,F7.4,1H(,3F5.2,1H), ' FMT12 = 'F9.1,F8.1,F6.1,F9.1,F8.5,1H ,I2,1H'',I2)' IF (VAL2.GT.9.0 .AND. VAL2.LT.95.0) THEN FMT11 = '(1X,I4,I5,F7.3,1H(,3F5.1,1H), ' ELSE IF (VAL2.GE.95.0) THEN FMT11 = '(1X,I4,I5,F7.2,1H(,3F5.0,1H), ' END IF IF (ABS(VAL(9)).LT.1.0D4.AND.ABS(VAL(14)).LT.1.0D4) THEN FMT12 = 'F9.2,F8.2,F6.2,F9.2,F8.5,1H ,I2,1H'',I2)' END IF IF (ABS(VAL(9)).LT.1.0D3.AND.ABS(VAL(14)).LT.1.0D3) THEN FMT12 = 'F9.3,F8.3,F6.3,F9.3,F8.5,1H ,I2,1H'',I2)' END IF ITEMP = VAL(1) WRITE (*,FMT1) MOD(NRECRD(1),10000),ITEMP,VAL(2),VAL(3), * VAL(4),VAL(5),VAL(9),VAL(10),VAL(11), * VAL(14),VAL(17),IMINUT,ISECND KKTIME(1,2) = IYEAR KKTIME(2,2) = IMONTH KKTIME(3,2) = IDAY KKTIME(4,2) = IHOUR KKTIME(5,2) = IMINUT KKTIME(6,2) = ISECND KKTIME(7,2) = I100TH END IF IF (RUNOPT(14).EQ.'DIPOLE ') THEN WRITE (*,9917) DIPM2,VAL(14)+DIPM2 9917 FORMAT (10X,7X,15X,'Dipole:',4X,F8.3,5X,F9.2) END IF C C ----------------------------------------------------- M.s.d., etc. IF (MOD(NRECRD(1),5).EQ.0) THEN IF (ABS(ECORR*FJMOL).GT.1.0E-10) THEN C WRITE (*,2880) VCORR / (3.0D0*VOL*1.0D-24)*1.0D-10, C * ECORR*FJMOL C2880 FORMAT (9X, F8.4,' GPa(Pcorr)',9X, C * 'Ecorr=',F8.3,' kJ/mol') END IF IF (RUNOPT(17).EQ.'AMORPHOUS ') THEN if (val(35).lt.100.and.val(36).lt.100) then WRITE (*,2901) (VAL(J+34), ATOM(J),J=1,5) 2901 FORMAT (6X,'Msd:',5(F8.3,'(',A1,')')) else WRITE (*,2902) (VAL(J+34), ATOM(J),J=1,5) 2902 FORMAT (6X,'Msd:',5(F8.1,'(',A1,')')) end if END IF IF (RUNOPT(17).EQ.'CRYSTAL ') THEN WRITE (*,2905) (VAL(J+34), ATOM(J),J=1,5), VAL(19), * VAL(20), VAL(21) 2905 FORMAT (1X,'Msd:',5(F6.3,':',A1),1X,3F7.3) END IF if (av3BP(2,1).gt.0.1 .or. av3bp(2,2).gt.0.1 .or. * av3BP(2,3).gt.0.1 .or. av3bp(2,4).gt.0.1) then write (6,2908) (AV3BP(1,i),INT(AV3BP(2,i)),i=1,n3bp) 2908 format (6x,'3p :', 4(F8.3,'(',i6,')')) end if END IF IF (RUNOPT(3).EQ.'DETAIL ') GO TO 670 IF (RUNOPT(3).EQ.'ECONOMY ') GO TO 690 IF (MOD(NRECRD(1),5).NE.0.AND.NRECRD(3).NE.1) GO TO 690 670 DO 680 I = 1, LEM IVAL(I) = INT(VAL(I+24)) 680 CONTINUE VAL2 = ABS(VAL(2)) FMT11 = '(1X,I5,5I5,F8.4,1H(,6F6.3,1H), ' FMT12 = ' F10.2,F9.2,2F7.2,F10.3, F9.5 ) ' IF (VAL2.GT.9.0 .AND. VAL2.LT.95.0) THEN FMT11 = '(1X,I5,5I5,F8.3,1H(,6F6.3,1H), ' ELSE IF (VAL2.GE.95.0) THEN FMT11 = '(1X,I5,5I5,F8.2,1H(,6F6.2,1H), ' END IF IF (ABS(VAL(9)).LT.1.0D4.AND.ABS(VAL(14)).LT.1.0D4) THEN FMT12 = ' F10.3,F9.3,2F7.3,F10.4, F9.5 ) ' END IF WRITE (16,FMT1) mod(NRECRD(1),100000), (IVAL(I),I=1,4), * INT(VAL(1)), (VAL(J),J= 2,11), VAL(13), * VAL(14),VAL(17) C 690 IF (MOD(NRECRD(1),25).EQ.0) THEN IF (RUNOPT(3).NE.'ECONOMY ') WRITE (16,2900) * (VAL(J),J=35,LVA) 2900 FORMAT (7X,5F8.3 / 7x,5F8.3 ) END IF RETURN END C C C ================ C=======================================================Center_of_DIATOM SUBROUTINE Center_of_Diatomic_Molecule PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C =======================================recognize diatomic molecule COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /CARTES/ H(3,3),HINV(3,3),FTOQ(3,3),RBOX(6), * G(3,3),GINV(3,3),TRANSX(8),TRANSY(8),TRANSZ(8) CT * ,Q(3,LNI),Q0(3,LNI) REAL *8 H,HINV,G,GINV,FTOQ,RBOX,TRANSX,TRANSY,TRANSZ COMMON /FORCES/ FX(LNI),FY(LNI),FZ(LNI) REAL *8 FX, FY, FZ COMMON /WORK01/ PX(LNI),PY(LNI),PZ(LNI) REAL *8 PX,PY,PZ COMMON /WORK02/ UUII(LNI),ZII(LNI),ZICOS(LNI),ZISIN(LNI) REAL *8 ZICOS, ZISIN COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME c COMMON /MOLECU/ ZMOLE(2), DMOLE(4,LNI), DINTRA(2), * NDMOLE, IDMOLE(3,LNI), IATOM2(2), MOLstart(2), * NMOLE, IMOLE(38,LNI), MMOLE(LNI), MOLend(2) real *8 zmole,dmole real *8 pix,piy,piz, pjx,pjy,pjz, rx,ry,rz, dx,dy,dz, * pjx0,pjy0,pjz0, rij2 c C---------------------------------------------calc distance of atoms cut2 = dintra(1)**2 do 900 im = 1, ndmole i=idmole(1,im) j=idmole(2,im) pix = p(1,i) piy = p(2,i) piz = p(3,i) pjx0 = p(1,j) pjy0 = p(2,j) pjz0 = p(3,j) if (pjx0.lt.pix) pjx0 = pjx0 + 1.0 if (pjy0.lt.piy) pjy0 = pjy0 + 1.0 if (pjz0.lt.piz) pjz0 = pjz0 + 1.0 DO 250 K = 1, 8 pjx = pjx0 - transx(k) pjy = pjy0 - transy(k) pjz = pjz0 - transz(k) RX = PIX - PjX RY = PIY - PjY RZ = PIZ - PjZ c - - - - - delete these if-statements for triclinic c IF (ABS(RX).GT.0.5) RX = RX - SIGN(1.0D0,RX) c IF (ABS(RY).GT.0.5) RY = RY - SIGN(1.0D0,RY) c IF (ABS(RZ).GT.0.5) RZ = RZ - SIGN(1.0D0,RZ) c DX = H(1,1)*RX + H(1,2)*RY + H(1,3)*RZ c DY = H(2,1)*RX + H(2,2)*RY + H(2,3)*RZ c DZ = H(3,1)*RX + H(3,2)*RY + H(3,3)*RZ DX = RX * BOX(1) DY = RY * BOX(2) DZ = RZ * BOX(3) RIJ2 = DX*DX + DY*DY + DZ*DZ if (rij2.lt.cut2) go to 255 250 CONTINUE go to 900 c -----------------------------------P of center of mass 255 Pix=(Pix+Pjx)/2. Piy=(Piy+Pjy)/2. Piz=(Piz+Pjz)/2. if (pix.lt.0.0) pix = pix + 1.0 if (pix.gt.1.0) pix = pix - 1.0 if (piy.lt.0.0) piy = piy + 1.0 if (piy.gt.1.0) piy = piy - 1.0 if (piz.lt.0.0) piz = piz + 1.0 if (piz.gt.1.0) piz = piz - 1.0 nnn = ntion+im p(1,nnn) = pix p(2,nnn) = piy p(3,nnn) = piz UI(nnn) = 0.0 FX(nnn) = 0.0D0 FY(nnn) = 0.0D0 FZ(nnn) = 0.0D0 PX(nnn) = P(1,nnn) PY(nnn) = P(2,nnn) PZ(nnn) = P(3,nnn) ZII(nnn) = Zmole(idmole(3,im)) DMOLE(1,IM) = DX DMOLE(2,IM) = Dy DMOLE(3,IM) = DZ DMOLE(4,IM) = SQRT(RIJ2) C write(*,*) nnn,DMOLE(1,IM),DMOLE(2,IM),DMOLE(3,IM) C * ,DMOLE(4,IM) 900 CONTINUE RETURN END C C C ======= C================================================================ EWALDS SUBROUTINE EWALDS (VIRLSR, PRSTC2) PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C C --------------------------------- Coulomb term by EWALD method and C short range interactions C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES(3),PPXYZ(7),FJMOL, * T000,T050, IAXTGR, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME COMMON /PARAMT/ AIO(LEM),BIO(LEM),CIO(LEM),DIO(LEM),ZIO(LEM), * AIJ(LEF),BIJ(LEF),CIJ(LEF),DIJ(LEF),D4IJ(LEF), * PLIJ(LEF),RSWTCH(LEF),ZIJ(LEF), D7IJ(LEF), * ECORR,VCORR, WIO(LEM), TWEGHT, AKFI(LEM), * ANG3BP(L3P), R3BLIM(2,L3P), * FK3BP(L3P), R3BGRD(2,L3P), R3lim(2,l3p),r3limax, * I3BP(3,L3P), N3BP COMMON /TABLES/ F1(LSR,LEE),E1(LSR,LEE),F0(LTB),E0(LTB) REAL *8 F1,E1,F0,E0 COMMON /PMORSE/ DMIJ(LEF), BEIJ(LEF), RSIJ(LEF), * DM1IJ(LEF), BE1IJ(LEF), DM2IJ(LEF),BE2IJ(LEF) COMMON /VECTOR/ FNV(LNV),UNV(LNV),PNV(6,LNV),ZIA(LEM),UCSELF, * ALPHA,UCSLFI(LEM), MODE, NVN, NVEC(3,LNV) REAL *8 FNV,UNV,PNV,ZIA,UCSELF,ALPHA,UCSLFI COMMON /CARTES/ H(3,3),HINV(3,3),FTOQ(3,3),RBOX(6), * G(3,3),GINV(3,3),TRANSX(8),TRANSY(8),TRANSZ(8) CT * ,Q(3,LNI),Q0(3,LNI) REAL *8 H,HINV,G,GINV,FTOQ,RBOX,TRANSX,TRANSY,TRANSZ COMMON /VALUES/ TVAL(LVA),TVALL(LVA),VALMAX(LVA),VAL0(LVA), * SVAL(LVA),SVALL(LVA),VALMIN(LVA), * VAL(LVA),AVA(LVA,L50), NAV,NAVT REAL *8 TVAL,SVAL,TVALL,SVALL,VALMAX,VALMIN,VAL0,VAL,AVA COMMON /RADIAL/ NRDF(LTB,LEE),IPRDF(2) INTEGER *4 NRDF COMMON /FORCES/ FX(LNI),FY(LNI),FZ(LNI) REAL *8 FX, FY, FZ COMMON /QUANCO/ Q1U1(LSR,LEE),Q2U1(LSR,LEE), * TQCE,QCEE,QCIT,QCEF,TEMPQH,TEMPQQ REAL *8 TQCE,QCEE,QCIT,QCEF COMMON /WORK01/ PX(LNI),PY(LNI),PZ(LNI) REAL *8 PX,PY,PZ COMMON /WORK02/ UUII(LNI),ZII(LNI),ZICOS(LNI),ZISIN(LNI) REAL *8 ZICOS, ZISIN COMMON /MOLECU/ ZMOLE(2), DMOLE(4,LNI), DINTRA(2), * NDMOLE, IDMOLE(3,LNI), IATOM2(2), MOLstart(2), * NMOLE, IMOLE(38,LNI), MMOLE(LNI), MOLend(2) real *8 zmole,dmole COMMON /CONSTS/ PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL REAL *8 PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL C COMMON /DATOMS/ D1ATOM, D1AXYZ(3), ddatom(50,lni), * D2ATOM, D2AXYZ(3), idatom(51,lni) REAL *8 D1ATOM, D1AXYZ, D2ATOM,D2AXYZ C INTEGER *4 IRDF(LTB) REAL *8 E2(LSR),F2(LSR) REAL *8 PIX,DX,RX,DFX,FIX, SICOS, SISIN,R00,X0,PHI,PRSTC2(6), * PIY,DY,RY,DFY,FIY,FSICOS,FSISIN,R01,X1,PI2,FIJ,FSIJ, * PIZ,DZ,RZ,DFZ,FIZ,USICOS,USISIN,R02,X2,UII,EIJ,ESIJ, * VAL03, VAL04, VAL05, VAL06, VAL07, VAL08, VAL09, * VAL03C,VAL04C,VAL05C,VAL06C,VAL07C,VAL08C,VAL10, * RIJ, RIJ2, RCUT2, VIRLSR, SCCSS, zizj REAL *8 Q1U2(LSR),Q2U2(LSR),QCEIJ,ANWIO,ANWJO,QS1,QS2 real *8 pjx0,pjy0,pjz0, zj, ECDD, FCDD real *8 arij, arij2, arij3, arij4, ddd real *8 sdx(lni),sdy(lni),sdz(lni), srij2(lni), srij(lni) integer *4 isj(lni) C CP REAL *8 AL2PI, ZIJE2, RIJ, ARIJ, ERFC, BETA, EX,CA,AM1,AM2 CP REAL *8 X0,X1,X2,X3, Y0,Y1,Y2,Y3,Y4, Z C ----- FUNCTION ERFC(X) : VERSION 5662 IN "COMPUTER APPROXIMATIONS" CP DATA EX0,EX1,EX2,EX3 / CP * 10.00464, 8.426553, 3.460259, .5623536 / CP DATA EY0,EY1,EY2,EY3,EY4/ CP * 10.00464, 19.71558, 15.70229, 6.090749, 1.0/ C C ----------------------- Put the central atom of 3-body interaction C at the last of atom species, to calculate C 3-body terms properly C do i=1, lni do n=1, 50 ddatom(n,i) = 0.0 idatom(n,i) = 0 end do idatom(51,i) = 0 end do c VAL03 = 0.0D0 VAL04 = 0.0D0 VAL05 = 0.0D0 VAL06 = 0.0D0 VAL07 = 0.0D0 VAL08 = 0.0D0 VAL09 = 0.0D0 VAL10 = 0.0D0 C VAL03C = 0.0D0 VAL04C = 0.0D0 VAL05C = 0.0D0 VAL06C = 0.0D0 VAL07C = 0.0D0 VAL08C = 0.0D0 VIRLSR = 0.0D0 TQCE = 0.0D0 C C ------------------------------------------ Coulomb reciprocal term C IF (NVN.EQ.0) GO TO 200 PI2 = PI * 2.0D0 DO 110 I = 1, NTION + ndmole ZICOS(I) = 0.0D0 ZISIN(I) = 0.0D0 110 CONTINUE C DO 170 IN = 1, NVN SICOS = 0.0D0 SISIN = 0.0D0 DX = NVEC(1,IN) * PI2 DY = NVEC(2,IN) * PI2 DZ = NVEC(3,IN) * PI2 DO 130 IO = 1, NCOMPO IF (IION(IO).LT.-998) GO TO 130 IF (NION(IO).GT.0.AND.ZIO(IO).NE.0.0) THEN I1 = IONS(1,IO) I2 = IONS(2,IO) ZJ = ZIO(IO) DO 120 I = I1, I2 PHI = DX*PX(I) + DY*PY(I) + DZ*PZ(I) ZICOS(I) = COS(PHI) * ZJ SICOS = SICOS + ZICOS(I) ZISIN(I) = SIN(PHI) * ZJ SISIN = SISIN + ZISIN(I) 120 CONTINUE END IF 130 CONTINUE if (runopt(23).eq.'DIATOMIC ') then I1 = ntion+1 I2 = ntion + ndmole DO 122 I = I1, I2 PHI = DX*PX(I) + DY*PY(I) + DZ*PZ(I) ZICOS(I) = COS(PHI) * Zii(i) SICOS = SICOS + ZICOS(I) ZISIN(I) = SIN(PHI) * Zii(i) SISIN = SISIN + ZISIN(I) 122 CONTINUE end if C FSICOS = FNV(IN) * SICOS FSISIN = FNV(IN) * SISIN USICOS = UNV(IN) * SICOS USISIN = UNV(IN) * SISIN SCCSS = SICOS**2 + SISIN**2 VAL09 = VAL09 + UNV(IN) * SCCSS VAL03C = VAL03C + PNV(1,IN) * SCCSS VAL04C = VAL04C + PNV(2,IN) * SCCSS VAL05C = VAL05C + PNV(3,IN) * SCCSS VAL06C = VAL06C + PNV(4,IN) * SCCSS VAL07C = VAL07C + PNV(5,IN) * SCCSS VAL08C = VAL08C + PNV(6,IN) * SCCSS FIX = NVEC(1,IN) * RBOX(1) FIY = NVEC(2,IN) * RBOX(2) FIZ = NVEC(3,IN) * RBOX(3) DO 150 I = 1, NTION UI(I) = USICOS * ZICOS(I) + USISIN * ZISIN(I) + UI(I) FIJ = FSICOS * ZISIN(I) - FSISIN * ZICOS(I) FX(I) = FX(I) + FIJ * FIX FY(I) = FY(I) + FIJ * FIY FZ(I) = FZ(I) + FIJ * FIZ 150 CONTINUE if (runopt(23).eq.'DIATOMIC ') then DO 152 I = NTION+1, ntion+ndmole UI(I) = USICOS*ZICOS(I) + USISIN*ZISIN(I) + UI(I) FIJ = FSICOS * ZISIN(I) - FSISIN * ZICOS(I) FX(I) = FX(I) + FIJ * FIX FY(I) = FY(I) + FIJ * FIY FZ(I) = FZ(I) + FIJ * FIZ 152 CONTINUE end if 170 CONTINUE C VAL09 = VAL09 * 0.5D0 C C --------------- Coulomb direct lattice space and short range terms C 200 RCUT2 = RCUT(1) * RCUT(1) CP AL2PI = 2.0D0 * ALPHA / SQRT(PI) CP BETA = CAL * 1.0D10 / ANA max_nsatom = 0 IN = 0 DO 390 IO = 1, NCOMPO DO 380 JO = 1, IO IN = IO*(IO-1)/2 + JO IF (IO.LT.JO) IN = JO*(JO-1)/2 + IO IF (IION(IO).LE.-998 .OR. IION(JO).LE.-998) GO TO 380 IF (NION(IO).LE.0 .OR. NION(JO).LE.0) GO TO 380 IF (IO.EQ.JO .AND. NION(IO).LE.1) GO TO 380 c ZIZJ = ZIO(IO) * ZIO(JO) CP ZIJE2 = ZIO(IO) * ZIO(JO) * ELC**2 CP DMIJN = DMIJ(IN) * BETA CP BEIJN = BEIJ(IN) DO 220 K = 1, NRCUT(2) E2(K) = E1(K,IN) F2(K) = F1(K,IN) 220 CONTINUE IF (RUNOPT(12).EQ.'QUANTUM ') THEN DO 230 K = 1, NRCUT(2) Q1U2(K) = Q1U1(K,IN) Q2U2(K) = Q2U1(K,IN) 230 CONTINUE QCEIJ = 0.0D0 END IF DO 240 K = 1, NRCUT(1)+1 IRDF(K) = 0 240 CONTINUE I1 = IONS(1,IO) I2 = IONS(2,IO) J1 = IONS(1,JO) J2 = IONS(2,JO) IF (IO.EQ.JO) I1 = I1 + 1 DO 320 I = I1, I2 PIX = PX(I) PIY = PY(I) PIZ = PZ(I) CT IF (PIX.GE.0.5D0) PIX = PIX - 1.0D0 CT IF (PIY.GE.0.5D0) PIY = PIY - 1.0D0 CT IF (PIZ.GE.0.5D0) PIZ = PIZ - 1.0D0 FIX = 0.0D0 FIY = 0.0D0 FIZ = 0.0D0 UII = 0.0D0 nsatom = 0 IF (IO.EQ.JO) J2 = I - 1 DO 260 J = J1, J2 CT DO 250 K = 1, 8 CT RX = PIX - PX(J) + TRANSX(K) CT RY = PIY - PY(J) + TRANSY(K) CT RZ = PIZ - PZ(J) + TRANSZ(K) RX = PIX - PX(J) RY = PIY - PY(J) RZ = PIZ - PZ(J) CT - - - - - delete these if-statements for triclinic IF (ABS(RX).GT.0.5) RX = RX - SIGN(1.0D0,RX) IF (ABS(RY).GT.0.5) RY = RY - SIGN(1.0D0,RY) IF (ABS(RZ).GT.0.5) RZ = RZ - SIGN(1.0D0,RZ) CT DX = H(1,1)*RX + H(1,2)*RY + H(1,3)*RZ CT DY = H(2,1)*RX + H(2,2)*RY + H(2,3)*RZ CT DZ = H(3,1)*RX + H(3,2)*RY + H(3,3)*RZ DX = RX * BOX(1) DY = RY * BOX(2) DZ = RZ * BOX(3) RIJ2 = DX*DX + DY*DY + DZ*DZ IF (RIJ2.LE.RCUT2) then nsatom = nsatom + 1 isj(nsatom) = j sDX(nsatom) = dx sDY(nsatom) = dy sDZ(nsatom) = dz sRIJ2(nsatom) = rij2 end if CT 250 CONTINUE 260 continue C if (max_nsatom.lt.nsatom) max_nsatom = nsatom c do 262 jj = 1, nsatom j = isj(jj) dx = sDX(jj) dy = sDY(jj) dz = sDZ(jj) rij2 = srij2(jj) RIJ = SQRT(RIJ2) ARIJ = 1.0D0 / RIJ srij(jj) = rij C ----------------------------------- Interpolation IP0 = INT(RIJ*100.0) IP1 = IP0 + 1 IP2 = IP0 + 2 R00 = IP0 * 0.01D0 R01 = IP1 * 0.01D0 R02 = IP2 * 0.01D0 C X0 = (RIJ-R01)*(RIJ-R02)/((R00-R01)*(R00-R02)) C X1 = (RIJ-R00)*(RIJ-R02)/((R01-R00)*(R01-R02)) C X2 = (RIJ-R00)*(RIJ-R01)/((R02-R00)*(R02-R01)) X0 = (RIJ-R01)*(RIJ-R02) * 5000.0 X1 = (RIJ-R00)*(RIJ-R02) * (-10000.0) X2 = (RIJ-R00)*(RIJ-R01) * 5000.0 FIJ = (F0(IP0)*X0 +F0(IP1)*X1 +F0(IP2)*X2)*ZIZJ EIJ = (E0(IP0)*X0 +E0(IP1)*X1 +E0(IP2)*X2)*ZIZJ CE ------------------------ For precise calculations C ------ FUNCTION ERFC(X) : VERSION 5662 C ------ in "COMPUTER APPROXIMATIONS" CE Z = ABS(ALPHA * RIJ) CE ERFC = EXP(-Z*Z) * CE * (EX0+Z*(EX1+Z*(EX2+Z*EX3))) / CE * (EY0+Z*(EY1+Z*(EY2+Z*(EY3+Z*EY4))) ) CE EIJ = ERFC * (ARIJ*1.0D8) * ZIJE2 CE FIJ = (AL2PI*EXP(-(ALPHA*RIJ)**2)*RIJ + ERFC) CE * * (ARIJ*1.0D8)**2 * ARIJ *ZIJE2 CE ------------------------------------------------- VAL09 = VAL09 + EIJ C --------- Charge-dipole and dipole-induced dipole IF (RIJ.GT.RSWTCH(IN) .and. * abs(cij(in)+dij(in)+d4ij(in)+d7ij(in)).gt.0.0) * then ARIJ2 = ARIJ * ARIJ ARIJ3 = ARIJ2 * ARIJ ARIJ4 = ARIJ3 * ARIJ ECDD = (-CIJ(IN)*ARIJ2 -DIJ(IN)*ARIJ4 * -D4IJ(IN) -D7IJ(IN)*ARIJ3)*ARIJ4 FCDD = - (6.0*CIJ(IN) *ARIJ3 + * 8.0*DIJ(IN) *ARIJ2*ARIJ3 + * 4.0*D4IJ(IN)*ARIJ + * 7.0*D7IJ(IN)*ARIJ4)*ARIJ4 * * ARIJ*1.0D8 EIJ = EIJ + ECDD FIJ = FIJ + FCDD VAL10 = VAL10 + ECDD VIRLSR = VIRLSR + FCDD*RIJ2 END IF C ------------------------------ Short range forces esij = 0.0 fsij = 0.0 IF (RIJ.LE.RCUT(2)) THEN C ---------------------------- Interpolation FSIJ = F2(IP0)*X0 +F2(IP1)*X1 +F2(IP2)*X2 ESIJ = E2(IP0)*X0 +E2(IP1)*X1 +E2(IP2)*X2 CS ----------------- For precise calculations CS EX = EXP((AIJ(IN) - RIJ) / BIJ(IN)) CS CA = CIJ(IN)*ARIJ**6 CS ESIJ = BETA* (BIJ(IN)*EX - CA) CS FSIJ = BETA* (EX - 6.0D0*CA*ARIJ) CS IF (DMIJ(IN).GT.0.001) THEN CS AM1= EXP(-2.0D0*BEIJN*(RIJ-RSIJ(IN))) CS AM2= EXP(-1.0D0*BEIJN*(RIJ-RSIJ(IN))) CS ESIJ= ESIJ+DMIJN*(AM1-2.0D0*AM2) CS FSIJ= FSIJ+BEIJN*DMIJN*2.0D0*(AM1-AM2) CS END IF CS FSIJ = FSIJ*1.0D8 * ARIJ C ------------------------------------------ FIJ = FIJ + FSIJ EIJ = EIJ + ESIJ VAL10 = VAL10 + ESIJ VIRLSR = VIRLSR + FSIJ*RIJ2 C ------------------------------------------ END IF UII = UII + EIJ UI(J) = UI(J) + EIJ DFX = FIJ * DX DFY = FIJ * DY DFZ = FIJ * DZ FIX = FIX + DFX FIY = FIY + DFY FIZ = FIZ + DFZ FX(J) = FX(J) - DFX FY(J) = FY(J) - DFY FZ(J) = FZ(J) - DFZ VAL03 = VAL03 + DFX * DX VAL04 = VAL04 + DFY * DY VAL05 = VAL05 + DFZ * DZ VAL06 = VAL06 + DFX * DY VAL07 = VAL07 + DFX * DZ VAL08 = VAL08 + DFY * DZ 262 CONTINUE FX(I) = FX(I) + FIX FY(I) = FY(I) + FIY FZ(I) = FZ(I) + FIZ UI(I) = UI(I) + UII do 264 jj = 1, nsatom IP0 = INT(srij(jj)*100.0) IRDF(IP0) = IRDF(IP0) + 1 if (srij(jj).le.r3limax) then idatom(51,i)= idatom(51,i) + 1 ddatom(idatom(51,i),i) = srij(jj) idatom(idatom(51,i),i) = isj(jj) + jo*1000000 j=isj(jj) idatom(51,j)= idatom(51,j) + 1 ddatom(idatom(51,j),j) = srij(jj) idatom(idatom(51,j),j) = i + io*1000000 end if 264 continue C ---------------------------------- Quantum correction term IF (RUNOPT(12).EQ.'QUANTUM ') THEN DO 280 J = 1, NsATOM RIJ = srij(J) IF (RIJ.LE.RCUT(2)) THEN IP0 = INT(RIJ*100.0) IP1 = IP0 + 1 IP2 = IP0 + 2 R00 = IP0 * 0.01 R01 = IP1 * 0.01 R02 = IP2 * 0.01 C X0 = (RIJ-R01)*(RIJ-R02)/((R00-R01)*(R00-R02)) C X1 = (RIJ-R00)*(RIJ-R02)/((R01-R00)*(R01-R02)) C X2 = (RIJ-R00)*(RIJ-R01)/((R02-R00)*(R02-R01)) X0 = (RIJ-R01)*(RIJ-R02) * 5000.0 X1 = (RIJ-R00)*(RIJ-R02) * (-10000.0) X2 = (RIJ-R00)*(RIJ-R01) * 5000.0 QS1 = Q1U2(IP0)*X0 +Q1U2(IP1)*X1 +Q1U2(IP2)*X2 QS2 = Q2U2(IP0)*X0 +Q2U2(IP1)*X1 +Q2U2(IP2)*X2 C CQ ARIJ = 1.0D0 / RIJ C ------------ Short range rep. and van der Waals CQ QS1 = -EXP((AIJ(IN) - RIJ) / BIJ(IN)) * 1.0E8 CQ QS2 = -QS1 / BIJ(IN) * 1.0E8 C --------------------------------- Van der Waals CQ QVW = 6.0 * CIJ(IN) * ARIJ**7 * 1.0E8 CQ QS1 = QS1 + QVW CQ QS2 = QS2 - 7.0 * QVW * ARIJ * 1.0E8 C ------------------------------------ Morse term CQ QMS1 = 0.0 CQ QMS2 = 0.0 CQ IF (DMIJ(IN).GT.0.001) THEN CQ D2 = DMIJ(IN) * 2.0D0 CQ AM1 = EXP(-2.0D0*BEIJN*(RIJ-RSIJ(IN))) CQ AM2 = EXP(-1.0D0*BEIJN*(RIJ-RSIJ(IN))) CQ QMS1= D2*BEIJN * ( -AM1+AM2) *1.0E8 CQ QMS2= D2*BEIJN**2 * (2.0*AM1-AM2) *1.0E16 CQ END IF CQ QS1 = (QS1 + QMS1) *BETA *ARIJ*1.0E8 CQ QS2 = (QS2 + QMS2) *BETA C QCEIJ = QCEIJ + ( 2.0*QS1 + QS2 ) end if 280 CONTINUE END IF 320 CONTINUE IF (RUNOPT(12).EQ.'QUANTUM ') THEN ANWIO = ANA / WIO(IO) ANWJO = ANA / WIO(JO) C ------------------------------------ QCEij : nabla(Uij) C TQCE : sum of nabla(Uij)/mi TQCE = TQCE + QCEIJ*ANWIO + QCEIJ*ANWJO END IF IF (MOD(NRECRD(1),IRECRD(5)).EQ.0) THEN DO L = 1, NRCUT(1) NRDF(L,IN) = NRDF(L,IN) + IRDF(L) end do end if 380 CONTINUE 390 CONTINUE c c -------------------------------------------- Calculate 3-body term ///// c if (N3BP.gt.0) then ///// do 490 io = 1, ncompo ijk = 0 do n = 1, n3bp if (io.eq.i3bp(2,n)) ijk = n end do if (ijk.eq.0) goto 490 c ///// do 480 i=ions(1,io), ions(2,io) mm = idatom(51,i) c write (6,*) i,mm ///// if (mm.le.1) go to 480 c ------------------------------------- sorting with distrance ///// do 410 j = 1, mm-1 do 410 k = j+1, mm if (ddatom(j,i).gt.ddatom(k,i)) then ddd = ddatom(j,i) ddatom(j,i) = ddatom(k,i) ddatom(k,i) = ddd iii = idatom(j,i) idatom(j,i) = idatom(k,i) idatom(k,i) = iii end if 410 continue c ///// 420 pix = px(i) piy = py(i) piz = pz(i) do 470 jj = 1, mm-1 jo = idatom(jj,i) / 1000000 j = mod(idatom(jj,i),1000000) RX = PIX - PX(J) RY = PIY - PY(J) RZ = PIZ - PZ(J) IF (ABS(RX).GT.0.5) RX = RX - SIGN(1.0D0,RX) IF (ABS(RY).GT.0.5) RY = RY - SIGN(1.0D0,RY) IF (ABS(RZ).GT.0.5) RZ = RZ - SIGN(1.0D0,RZ) D1AXYZ(1) = RX * BOX(1) D1AXYZ(2) = RY * BOX(2) D1AXYZ(3) = RZ * BOX(3) D1ATOM = sqrt(d1axyz(1)**2 + d1axyz(2)**2 * + d1axyz(3)**2) do 460 kk = jj+1, mm ko = idatom(kk,i) / 1000000 k = mod(idatom(kk,i),1000000) RX = PIX - PX(k) RY = PIY - PY(k) RZ = PIZ - PZ(k) IF (ABS(RX).GT.0.5) RX = RX - SIGN(1.0D0,RX) IF (ABS(RY).GT.0.5) RY = RY - SIGN(1.0D0,RY) IF (ABS(RZ).GT.0.5) RZ = RZ - SIGN(1.0D0,RZ) D2AXYZ(1) = RX * BOX(1) D2AXYZ(2) = RY * BOX(2) D2AXYZ(3) = RZ * BOX(3) D2ATOM = sqrt(d2axyz(1)**2 + d2axyz(2)**2 * + d2axyz(3)**2) c ///// DO 440 N = 1, N3BP IF (io.EQ.I3BP(2,N) .AND. jo.EQ.i3BP(1,N) .and. * jo.eq.ko .and. ko.EQ.i3BP(3,N)) then if (d1atom.le.r3lim(1,n) .and. * d2atom.le.r3lim(1,n) ) then c -------------------------- 3-body potential B-A-B ///// c ///// CALL THREEP (I,j,k, n, VIRLSR) c ///// end if END IF c ///// IF (IO.EQ.I3BP(2,N) .AND. JO.EQ.i3BP(1,n) .and. * i3BP(1,N).ne.i3BP(3,N).and. ko.eq.i3bp(3,n)) then C ------------------------------------ 3-body B-A-C ///// c ///// if (d1atom.le.r3lim(1,n) .and. * d2atom.le.r3lim(2,n) ) then call threeq (I,j,k, N, VIRLSR, * d1atom,d1axyz,d2atom,d2axyz) end if end if c ///// IF (IO.EQ.I3BP(2,N) .AND. JO.EQ.i3BP(3,n) .and. * i3BP(1,N).ne.i3BP(3,N).and. ko.eq.i3bp(1,n)) then C ------------------------------------ 3-body C-A-B c ///// if (d1atom.le.r3lim(2,n) .and. * d2atom.le.r3lim(1,n) ) then call threeq (I,k,j, N, VIRLSR, * d2atom,d2axyz,d1atom,d1axyz) end if end if 440 CONTINUE 460 continue 470 continue 480 continue 490 continue c end if ///// c c write(6,*)val(3),val(4),val(5),val(6),val(7),val(8),val(11),virlsr ????? c if (max_nsatom.gt.1234) write (6,*) 'Max(nsatom)=',max_nsatom c c ------------------ Calculation of Coulomb of three point charges if (runopt(23).eq.'DIATOMIC ') then do 399 L = 1, 2 i1 = ntion + 1 i2 = ntion + ndmole if (L .eq. 2) i1 = ntion + 2 DO 392 I = i1, i2 PIX = PX(I) PIY = PY(I) PIZ = PZ(I) FIX = 0.0D0 FIY = 0.0D0 FIZ = 0.0D0 UII = 0.0D0 j1 = 1 j2 = ntion IF (L.EQ.2) THEN J1 = NTION + 1 j2 = I-1 END IF DO 382 J = j1, j2 ZIZJ = ZII(I) * ZII(J) CP ZIJE2 = ZIO(IO) * ZIO(JO) * ELC**2 pjx0 = p(1,j) pjy0 = p(2,j) pjz0 = p(3,j) if (pjx0.lt.pix) pjx0 = pjx0 + 1.0 if (pjy0.lt.piy) pjy0 = pjy0 + 1.0 if (pjz0.lt.piz) pjz0 = pjz0 + 1.0 DO 352 K = 1, 8 pjx = pjx0 - transx(k) pjy = pjy0 - transy(k) pjz = pjz0 - transz(k) RX = PIX - PjX RY = PIY - PjY RZ = PIZ - PjZ c - - - - - delete these if-statements for triclinic c IF (ABS(RX).GT.0.5) RX = RX - SIGN(1.0D0,RX) c IF (ABS(RY).GT.0.5) RY = RY - SIGN(1.0D0,RY) c IF (ABS(RZ).GT.0.5) RZ = RZ - SIGN(1.0D0,RZ) c DX = H(1,1)*RX + H(1,2)*RY + H(1,3)*RZ c DY = H(2,1)*RX + H(2,2)*RY + H(2,3)*RZ C DZ = H(3,1)*RX + H(3,2)*RY + H(3,3)*RZ DX = RX * BOX(1) DY = RY * BOX(2) DZ = RZ * BOX(3) RIJ2 = DX*DX + DY*DY + DZ*DZ IF (RIJ2.LE.RCUT2) GO TO 357 352 CONTINUE GO TO 362 C 357 RIJ = SQRT(RIJ2) IP0 = INT(RIJ*100.0) C ---------------------------------- Interpolation IP1 = IP0 + 1 IP2 = IP0 + 2 R00 = IP0 * 0.01D0 R01 = IP1 * 0.01D0 R02 = IP2 * 0.01D0 C X0 = (RIJ-R01)*(RIJ-R02)/((R00-R01)*(R00-R02)) C X1 = (RIJ-R00)*(RIJ-R02)/((R01-R00)*(R01-R02)) C X2 = (RIJ-R00)*(RIJ-R01)/((R02-R00)*(R02-R01)) X0 = (RIJ-R01)*(RIJ-R02) * 5000.0 X1 = (RIJ-R00)*(RIJ-R02) * (-10000.0) X2 = (RIJ-R00)*(RIJ-R01) * 5000.0 FIJ = (F0(IP0)*X0 +F0(IP1)*X1 +F0(IP2)*X2)*ZIZJ EIJ = (E0(IP0)*X0 +E0(IP1)*X1 +E0(IP2)*X2)*ZIZJ CE ----------------------- For precise calculations CE ARIJ = 1.0D0 / RIJ C ------ FUNCTION ERFC(X) : VERSION 5662 C ------ in "COMPUTER APPROXIMATIONS" CE Z = ABS(ALPHA * RIJ) CE ERFC = EXP(-Z*Z) * CE * (EX0+Z*(EX1+Z*(EX2+Z*EX3))) / CE * (EY0+Z*(EY1+Z*(EY2+Z*(EY3+Z*EY4))) ) CE EIJ = ERFC * (ARIJ*1.0D8) * ZIJE2 CE FIJ = (AL2PI*EXP(-(ALPHA*RIJ)**2)*RIJ + ERFC) CE * * (ARIJ*1.0D8)**2 * ARIJ *ZIJE2 CE ------------------------------------------------ VAL09 = VAL09 + EIJ UII = UII + EIJ UI(J) = UI(J) + EIJ DFX = FIJ * DX DFY = FIJ * DY DFZ = FIJ * DZ FIX = FIX + DFX FIY = FIY + DFY FIZ = FIZ + DFZ FX(J) = FX(J) - DFX FY(J) = FY(J) - DFY FZ(J) = FZ(J) - DFZ VAL03 = VAL03 + DFX * DX VAL04 = VAL04 + DFY * DY VAL05 = VAL05 + DFZ * DZ VAL06 = VAL06 + DFX * DY VAL07 = VAL07 + DFX * DZ VAL08 = VAL08 + DFY * DZ 362 CONTINUE 382 CONTINUE FX(I) = FX(I) + FIX FY(I) = FY(I) + FIY FZ(I) = FZ(I) + FIZ UI(I) = UI(I) + UII 392 CONTINUE 399 continue end if C ------------------------------------------------------------------ VAL(3) = VAL(3) + VAL03*1.0D-8 + VAL03C VAL(4) = VAL(4) + VAL04*1.0D-8 + VAL04C VAL(5) = VAL(5) + VAL05*1.0D-8 + VAL05C VAL(6) = VAL(6) + VAL06*1.0D-8 + VAL06C VAL(7) = VAL(7) + VAL07*1.0D-8 + VAL07C VAL(8) = VAL(8) + VAL08*1.0D-8 + VAL08C VAL(9) = VAL(9) + VAL09 VAL(10) = VAL(10) + VAL10 PRSTC2(1) = VAL03C PRSTC2(2) = VAL04C PRSTC2(3) = VAL05C PRSTC2(4) = VAL06C PRSTC2(5) = VAL07C PRSTC2(6) = VAL08C C C ----------------------------------- Cancel intra-molecular Coulomb C of diatomic molecules IF (RUNOPT(23).EQ.'DIATOMIC ') CALL EWALD_of_DiAtoms (PRSTC2) c C ----------------------------------- Cancel intra-molecular Coulomb C of diatomic molecules IF (RUNOPT(29).EQ.'POLYATOMS ') CALL EWALD_of_PolyAtoms (PRSTC2) C C ---------------------------------------------- RDF for dummy atoms IN = 0 DO 790 IO = 1, NCOMPO DO 780 JO = 1, IO IN = IN + 1 IF (IION(IO).GT.-998 .AND. NION(JO).GT.-998) GO TO 780 IF (NION(IO).LE.0 .OR. NION(JO).LE.0) GO TO 780 IF (IO.EQ.JO .AND. NION(IO).LE.1) GO TO 780 DO 720 K = 1, NRCUT(1)+1 IRDF(K) = 0 720 CONTINUE I1 = IONS(1,IO) I2 = IONS(2,IO) J1 = IONS(1,JO) J2 = IONS(2,JO) IF (IO.EQ.JO) I1 = I1 + 1 DO 760 I = I1, I2 PIX = PX(I) PIY = PY(I) PIZ = PZ(I) IF (IO.EQ.JO) J2 = I - 1 DO 750 J = J1, J2 CT DO 740 K = 1, 8 CT RX = ABS(PIX - PX(J) + TRANSX(K)) CT RY = ABS(PIY - PY(J) + TRANSY(K)) CT RZ = ABS(PIZ - PZ(J) + TRANSZ(K)) CT DX = H(1,1)*RX + H(1,2)*RY + H(1,3)*RZ CT DY = H(2,1)*RX + H(2,2)*RY + H(2,3)*RZ CT DZ = H(3,1)*RX + H(3,2)*RY + H(3,3)*RZ DX = ABS(PIX - PX(J)) DY = ABS(PIY - PY(J)) DZ = ABS(PIZ - PZ(J)) CT - - - - - delete these if-statements for triclinic IF (ABS(DX).GT.0.5) DX = 1.0 - DX IF (ABS(DY).GT.0.5) DY = 1.0 - DY IF (ABS(DZ).GT.0.5) DZ = 1.0 - DZ RIJ2 = (DX * BOX(1))**2 + (DY * BOX(2))**2 * + (DZ * BOX(3))**2 IF (RIJ2.LE.RCUT2) GO TO 755 CT 740 CONTINUE GO TO 750 755 CONTINUE IP0 = INT( SQRT(RIJ2) * 100.0 ) IF (IP0.LT.1) IP0 = 1 IRDF(IP0) = IRDF(IP0) + 1 750 CONTINUE 760 CONTINUE DO 770 L = 1, NRCUT(1) NRDF(L,IN) = NRDF(L,IN) + IRDF(L) 770 CONTINUE 780 CONTINUE 790 CONTINUE RETURN END C C C =================== C====================================================== EWALD_of_DiAtoms SUBROUTINE EWALD_of_DiAtoms (PRSTC2) PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C C --------------------------------- Coulomb term by EWALD method and C short range interactions C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME COMMON /PARAMT/ AIO(LEM),BIO(LEM),CIO(LEM),DIO(LEM),ZIO(LEM), * AIJ(LEF),BIJ(LEF),CIJ(LEF),DIJ(LEF),D4IJ(LEF), * PLIJ(LEF),RSWTCH(LEF),ZIJ(LEF), D7IJ(LEF), * ECORR,VCORR, WIO(LEM), TWEGHT, AKFI(LEM), * ANG3BP(L3P), R3BLIM(2,L3P), * FK3BP(L3P), R3BGRD(2,L3P), R3lim(2,l3p),r3limax, * I3BP(3,L3P), N3BP COMMON /TABLES/ F1(LSR,LEE),E1(LSR,LEE),F0(LTB),E0(LTB) REAL *8 F1,E1,F0,E0 COMMON /VECTOR/ FNV(LNV),UNV(LNV),PNV(6,LNV),ZIA(LEM),UCSELF, * ALPHA,UCSLFI(LEM), MODE, NVN, NVEC(3,LNV) REAL *8 FNV,UNV,PNV,ZIA,UCSELF,ALPHA,UCSLFI COMMON /CARTES/ H(3,3),HINV(3,3),FTOQ(3,3),RBOX(6), * G(3,3),GINV(3,3),TRANSX(8),TRANSY(8),TRANSZ(8) CT * ,Q(3,LNI),Q0(3,LNI) REAL *8 H,HINV,G,GINV,FTOQ,RBOX,TRANSX,TRANSY,TRANSZ COMMON /VALUES/ TVAL(LVA),TVALL(LVA),VALMAX(LVA),VAL0(LVA), * SVAL(LVA),SVALL(LVA),VALMIN(LVA), * VAL(LVA),AVA(LVA,L50), NAV,NAVT REAL *8 TVAL,SVAL,TVALL,SVALL,VALMAX,VALMIN,VAL0,VAL,AVA COMMON /FORCES/ FX(LNI),FY(LNI),FZ(LNI) REAL *8 FX, FY, FZ COMMON /WORK01/ PX(LNI),PY(LNI),PZ(LNI) REAL *8 PX,PY,PZ COMMON /WORK02/ UUII(LNI),ZII(LNI),ZICOS(LNI),ZISIN(LNI) REAL *8 ZICOS, ZISIN COMMON /MOLECU/ ZMOLE(2), DMOLE(4,LNI), DINTRA(2), * NDMOLE, IDMOLE(3,LNI), IATOM2(2), MOLstart(2), * NMOLE, IMOLE(38,LNI), MMOLE(LNI), MOLend(2) real *8 zmole,dmole COMMON /CONSTS/ PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL REAL *8 PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL C REAL *8 PIX,DX,RX,DFX,FIX, SICOS, SISIN,R00,X0,PHI,PRSTC2(6), * PIY,DY,RY,DFY,FIY,FSICOS,FSISIN,R01,X1,PI2,FIJ, * PIZ,DZ,RZ,DFZ,FIZ,USICOS,USISIN,R02,X2,EIJ, * VAL03, VAL04, VAL05, VAL06, VAL07, VAL08, VAL09, * VAL03C,VAL04C,VAL05C,VAL06C,VAL07C,VAL08C,VAL09C, * RIJ, RIJ2, RCUT2, SCCSS, zizj real *8 pjx0,pjy0,pjz0, * pm(3,lni),zm(LNI),FM(3,LNI),um(3) C CP REAL *8 AL2PI, ZIJE2, RIJ, ARIJ, ERFC, BETA, EX,CA,AM1,AM2 CP REAL *8 X0,X1,X2,X3, Y0,Y1,Y2,Y3,Y4, Z C ----- FUNCTION ERFC(X) : VERSION 5662 IN "COMPUTER APPROXIMATIONS" CP DATA EX0,EX1,EX2,EX3 /10.00464,8.426553,3.460259,0.5623536 / CP DATA EY0,EY1,EY2,EY3,EY4/10.00464,19.71558,15.70229,6.090749,1.0/ C VAL03 = 0.0D0 VAL04 = 0.0D0 VAL05 = 0.0D0 VAL06 = 0.0D0 VAL07 = 0.0D0 VAL08 = 0.0D0 VAL09 = 0.0D0 C VAL03C = 0.0D0 VAL04C = 0.0D0 VAL05C = 0.0D0 VAL06C = 0.0D0 VAL07C = 0.0D0 VAL08C = 0.0D0 VAL09C = 0.0D0 C C ------------------------------------------ Coulomb reciprocal term C do 999 ijkl = 1, ndmole do 977 N=1, 2 I = IDMOLE(N,IJKL) ZM(N) = ZII(I) do 977 K = 1, 3 PM(K,N) = P(K,I) 977 CONTINUE ZM(3) = ZMOLE(IDMOLE(3,IJKL)) PM(1,3) = P(1,NTION+IJKL) PM(2,3) = P(2,NTION+IJKL) PM(3,3) = P(3,NTION+IJKL) DO 988 I = 1, 3 UM(I) = 0.0 DO 988 K = 1, 3 FM(K,I) = 0.0 988 CONTINUE IF (NVN.EQ.0) GO TO 200 PI2 = PI * 2.0D0 DO 110 I = 1, NTION ZICOS(I) = 0.0D0 ZISIN(I) = 0.0D0 110 CONTINUE C VAL09C = 0.0D0 DO 170 IN = 1, NVN SICOS = 0.0D0 SISIN = 0.0D0 DX = NVEC(1,IN) * PI2 DY = NVEC(2,IN) * PI2 DZ = NVEC(3,IN) * PI2 DO 122 I = 1, 3 PHI = DX*PM(1,I) + DY*PM(2,I) + DZ*PM(3,I) ZICOS(I) = COS(PHI) * ZM(i) SICOS = SICOS + ZICOS(I) ZISIN(I) = SIN(PHI) * ZM(i) SISIN = SISIN + ZISIN(I) 122 CONTINUE C FSICOS = FNV(IN) * SICOS FSISIN = FNV(IN) * SISIN USICOS = UNV(IN) * SICOS USISIN = UNV(IN) * SISIN SCCSS = SICOS**2 + SISIN**2 VAL09C = VAL09C + UNV(IN) * SCCSS VAL03C = VAL03C + PNV(1,IN) * SCCSS VAL04C = VAL04C + PNV(2,IN) * SCCSS VAL05C = VAL05C + PNV(3,IN) * SCCSS VAL06C = VAL06C + PNV(4,IN) * SCCSS VAL07C = VAL07C + PNV(5,IN) * SCCSS VAL08C = VAL08C + PNV(6,IN) * SCCSS FIX = NVEC(1,IN) * RBOX(1) FIY = NVEC(2,IN) * RBOX(2) FIZ = NVEC(3,IN) * RBOX(3) DO 152 I = 1, 3 UM(I) = USICOS * ZICOS(I) + USISIN * ZISIN(I) + UM(I) FIJ = FSICOS * ZISIN(I) - FSISIN * ZICOS(I) FM(1,I) = FM(1,I) + FIJ * FIX FM(2,I) = FM(2,I) + FIJ * FIY FM(3,I) = FM(3,I) + FIJ * FIZ 152 CONTINUE 170 CONTINUE VAL09 = VAL09 + VAL09C * 0.5D0 VAL91 = VAL91 + VAL09C*0.5D0 C C ----------------------------------- Coulomb direct lattice space C 200 RCUT2 = RCUT(1) * RCUT(1) CP AL2PI = 2.0D0 * ALPHA / SQRT(PI) c ------------------ Calculation of Coulomb of three point charges DO 392 I = 1, 2 PIX = PM(1,I) PIY = PM(2,I) PIZ = PM(3,I) DO 382 J = I+1, 3 ZIZJ = ZM(I) * ZM(J) pjx0 = pM(1,j) pjy0 = pM(2,j) pjz0 = pM(3,j) if (pjx0.lt.pix) pjx0 = pjx0 + 1.0 if (pjy0.lt.piy) pjy0 = pjy0 + 1.0 if (pjz0.lt.piz) pjz0 = pjz0 + 1.0 DO 252 K = 1, 8 pjx = pjx0 - transx(k) pjy = pjy0 - transy(k) pjz = pjz0 - transz(k) RX = PIX - PjX RY = PIY - PjY RZ = PIZ - PjZ c RX = PIX - PjX c RY = PIY - PjY c RZ = PIZ - PjZ c - - - - - delete these if-statements for triclinic c IF (ABS(RX).GT.0.5) RX = RX - SIGN(1.0D0,RX) c IF (ABS(RY).GT.0.5) RY = RY - SIGN(1.0D0,RY) c IF (ABS(RZ).GT.0.5) RZ = RZ - SIGN(1.0D0,RZ) c DX = H(1,1)*RX + H(1,2)*RY + H(1,3)*RZ c DY = H(2,1)*RX + H(2,2)*RY + H(2,3)*RZ C DZ = H(3,1)*RX + H(3,2)*RY + H(3,3)*RZ DX = RX * BOX(1) DY = RY * BOX(2) DZ = RZ * BOX(3) RIJ2 = DX*DX + DY*DY + DZ*DZ IF (RIJ2.LE.RCUT2) GO TO 257 252 CONTINUE GO TO 262 C 257 RIJ = SQRT(RIJ2) IP0 = INT(RIJ*100.0) C ---------------------------------- Interpolation IP1 = IP0 + 1 IP2 = IP0 + 2 R00 = IP0 * 0.01D0 R01 = IP1 * 0.01D0 R02 = IP2 * 0.01D0 C X0 = (RIJ-R01)*(RIJ-R02)/((R00-R01)*(R00-R02)) C X1 = (RIJ-R00)*(RIJ-R02)/((R01-R00)*(R01-R02)) C X2 = (RIJ-R00)*(RIJ-R01)/((R02-R00)*(R02-R01)) X0 = (RIJ-R01)*(RIJ-R02) * 5000.0 X1 = (RIJ-R00)*(RIJ-R02) * (-10000.0) X2 = (RIJ-R00)*(RIJ-R01) * 5000.0 FIJ = (F0(IP0)*X0 +F0(IP1)*X1 +F0(IP2)*X2)*ZIZJ EIJ = (E0(IP0)*X0 +E0(IP1)*X1 +E0(IP2)*X2)*ZIZJ CE ----------------------- For precise calculations CE ARIJ = 1.0D0 / RIJ C ------ FUNCTION ERFC(X) : VERSION 5662 C ------ in "COMPUTER APPROXIMATIONS" CE Z = ABS(ALPHA * RIJ) CE ERFC = EXP(-Z*Z) * CE * (EX0+Z*(EX1+Z*(EX2+Z*EX3))) / CE * (EY0+Z*(EY1+Z*(EY2+Z*(EY3+Z*EY4))) ) CE EIJ = ERFC * (ARIJ*1.0D8) * ZIJE2 CE FIJ = (AL2PI*EXP(-(ALPHA*RIJ)**2)*RIJ + ERFC) CE * * (ARIJ*1.0D8)**2 * ARIJ *ZIJE2 CE ------------------------------------------------ VAL09 = VAL09 + EIJ VAL92 = VAL92 + EIJ UM(I) = UM(I) + EIJ UM(J) = UM(J) + EIJ DFX = FIJ * DX DFY = FIJ * DY DFZ = FIJ * DZ FM(1,I) = FM(1,I) + DFX FM(2,I) = FM(2,I) + DFY FM(3,I) = FM(3,I) + DFZ FM(1,J) = FM(1,J) - DFX FM(2,J) = FM(2,J) - DFY FM(3,J) = FM(3,J) - DFZ VAL03 = VAL03 + DFX * DX VAL04 = VAL04 + DFY * DY VAL05 = VAL05 + DFZ * DZ VAL06 = VAL06 + DFX * DY VAL07 = VAL07 + DFX * DZ VAL08 = VAL08 + DFY * DZ 262 CONTINUE 382 CONTINUE 392 CONTINUE UI(NTION+IJKL) = UI(NTION+IJKL) - UM(3) FX(NTION+IJKL) = FX(NTION+IJKL) - FM(1,3) FY(NTION+IJKL) = FY(NTION+IJKL) - FM(2,3) FZ(NTION+IJKL) = FZ(NTION+IJKL) - FM(3,3) DO 955 II = 1, 2 I = IDMOLE(II,IJKL) UI(I) = UI(I) - UM(II) FX(I) = FX(I) - FM(1,II) FY(I) = FY(I) - FM(2,II) FZ(I) = FZ(I) - FM(3,II) fx(i) = fx(i) + fx(ntion+ijKL) / 2.0 fy(i) = fy(i) + fy(ntion+ijKL) / 2.0 fz(i) = fz(i) + fz(ntion+ijKL) / 2.0 ui(i) = ui(i) + ui(ntion+ijKL) / 2.0 955 CONTINUE 999 continue C VAL(3) = VAL(3) - VAL03*1.0D-8 - VAL03C VAL(4) = VAL(4) - VAL04*1.0D-8 - VAL04C VAL(5) = VAL(5) - VAL05*1.0D-8 - VAL05C VAL(6) = VAL(6) - VAL06*1.0D-8 - VAL06C VAL(7) = VAL(7) - VAL07*1.0D-8 - VAL07C VAL(8) = VAL(8) - VAL08*1.0D-8 - VAL08C VAL(9) = VAL(9) - VAL09 II = IATOM2(1) IF (II.NE.0) VAL(9) = VAL(9) - UCSLFI(II) II = IATOM2(2) IF (II.NE.0) VAL(9) = VAL(9) - UCSLFI(II) PRSTC2(1) = PRSTC2(1) - VAL03C PRSTC2(2) = PRSTC2(2) - VAL04C PRSTC2(3) = PRSTC2(3) - VAL05C PRSTC2(4) = PRSTC2(4) - VAL06C PRSTC2(5) = PRSTC2(5) - VAL07C PRSTC2(6) = PRSTC2(6) - VAL08C RETURN END C C C ===================== C==================================================== EWALD_of_PolyAtoms SUBROUTINE EWALD_of_PolyAtoms (PRSTC2) PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C C --------------------------------- Coulomb term by EWALD method and C short range interactions C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME COMMON /PARAMT/ AIO(LEM),BIO(LEM),CIO(LEM),DIO(LEM),ZIO(LEM), * AIJ(LEF),BIJ(LEF),CIJ(LEF),DIJ(LEF),D4IJ(LEF), * PLIJ(LEF),RSWTCH(LEF),ZIJ(LEF), D7IJ(LEF), * ECORR,VCORR, WIO(LEM), TWEGHT, AKFI(LEM), * ANG3BP(L3P), R3BLIM(2,L3P), * FK3BP(L3P), R3BGRD(2,L3P), R3lim(2,l3p),r3limax, * I3BP(3,L3P), N3BP COMMON /TABLES/ F1(LSR,LEE),E1(LSR,LEE),F0(LTB),E0(LTB) REAL *8 F1,E1,F0,E0 COMMON /VECTOR/ FNV(LNV),UNV(LNV),PNV(6,LNV),ZIA(LEM),UCSELF, * ALPHA,UCSLFI(LEM), MODE, NVN, NVEC(3,LNV) REAL *8 FNV,UNV,PNV,ZIA,UCSELF,ALPHA,UCSLFI COMMON /CARTES/ H(3,3),HINV(3,3),FTOQ(3,3),RBOX(6), * G(3,3),GINV(3,3),TRANSX(8),TRANSY(8),TRANSZ(8) CT * ,Q(3,LNI),Q0(3,LNI) REAL *8 H,HINV,G,GINV,FTOQ,RBOX,TRANSX,TRANSY,TRANSZ COMMON /VALUES/ TVAL(LVA),TVALL(LVA),VALMAX(LVA),VAL0(LVA), * SVAL(LVA),SVALL(LVA),VALMIN(LVA), * VAL(LVA),AVA(LVA,L50), NAV,NAVT REAL *8 TVAL,SVAL,TVALL,SVALL,VALMAX,VALMIN,VAL0,VAL,AVA COMMON /FORCES/ FX(LNI),FY(LNI),FZ(LNI) REAL *8 FX, FY, FZ COMMON /WORK01/ PX(LNI),PY(LNI),PZ(LNI) REAL *8 PX,PY,PZ COMMON /WORK02/ UUII(LNI),ZII(LNI),ZICOS(LNI),ZISIN(LNI) REAL *8 ZICOS, ZISIN COMMON /MOLECU/ ZMOLE(2), DMOLE(4,LNI), DINTRA(2), * NDMOLE, IDMOLE(3,LNI), IATOM2(2), MOLstart(2), * NMOLE, IMOLE(38,LNI), MMOLE(LNI), MOLend(2) real *8 zmole,dmole COMMON /CONSTS/ PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL REAL *8 PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL C REAL *8 PIX,DX,RX,DFX,FIX, SICOS, SISIN,R00,X0,PHI,PRSTC2(6), * PIY,DY,RY,DFY,FIY,FSICOS,FSISIN,R01,X1,PI2,FIJ, * PIZ,DZ,RZ,DFZ,FIZ,USICOS,USISIN,R02,X2,EIJ, * VAL03, VAL04, VAL05, VAL06, VAL07, VAL08, VAL09, * VAL03C,VAL04C,VAL05C,VAL06C,VAL07C,VAL08C,VAL09C, * RIJ, RIJ2, RCUT2, SCCSS, zizj real *8 pjx0,pjy0,pjz0, * pm(3,lni),zm(LNI),FM(3,LNI),um(3) C CP REAL *8 AL2PI, ZIJE2, RIJ, ARIJ, ERFC, BETA, EX,CA,AM1,AM2 CP REAL *8 X0,X1,X2,X3, Y0,Y1,Y2,Y3,Y4, Z C ----- FUNCTION ERFC(X) : VERSION 5662 IN "COMPUTER APPROXIMATIONS" CP DATA EX0,EX1,EX2,EX3 /10.00464,8.426553,3.460259,0.5623536 / CP DATA EY0,EY1,EY2,EY3,EY4/10.00464,19.71558,15.70229,6.090749,1.0/ C VAL03 = 0.0D0 VAL04 = 0.0D0 VAL05 = 0.0D0 VAL06 = 0.0D0 VAL07 = 0.0D0 VAL08 = 0.0D0 VAL09 = 0.0D0 C VAL03C = 0.0D0 VAL04C = 0.0D0 VAL05C = 0.0D0 VAL06C = 0.0D0 VAL07C = 0.0D0 VAL08C = 0.0D0 VAL09C = 0.0D0 C C ------------------------------------------ Coulomb reciprocal term C do 999 ijkl = 1, nmole do 977 N = 1, mmole(ijkl) I = IDMOLE(N,IJKL) ZM(N) = ZII(I) do 977 K = 1, 3 PM(K,N) = P(K,I) 977 CONTINUE DO 988 I = 1, mmole(ijkl) UM(I) = 0.0 DO 988 K = 1, 3 FM(K,I) = 0.0 988 CONTINUE IF (NVN.EQ.0) GO TO 200 PI2 = PI * 2.0D0 DO 110 I = 1, NTION ZICOS(I) = 0.0D0 ZISIN(I) = 0.0D0 110 CONTINUE C VAL09C = 0.0D0 DO 170 IN = 1, NVN SICOS = 0.0D0 SISIN = 0.0D0 DX = NVEC(1,IN) * PI2 DY = NVEC(2,IN) * PI2 DZ = NVEC(3,IN) * PI2 DO 122 I = 1, mmole(ijkl) PHI = DX*PM(1,I) + DY*PM(2,I) + DZ*PM(3,I) ZICOS(I) = COS(PHI) * ZM(i) SICOS = SICOS + ZICOS(I) ZISIN(I) = SIN(PHI) * ZM(i) SISIN = SISIN + ZISIN(I) 122 CONTINUE C FSICOS = FNV(IN) * SICOS FSISIN = FNV(IN) * SISIN USICOS = UNV(IN) * SICOS USISIN = UNV(IN) * SISIN SCCSS = SICOS**2 + SISIN**2 VAL09C = VAL09C + UNV(IN) * SCCSS VAL03C = VAL03C + PNV(1,IN) * SCCSS VAL04C = VAL04C + PNV(2,IN) * SCCSS VAL05C = VAL05C + PNV(3,IN) * SCCSS VAL06C = VAL06C + PNV(4,IN) * SCCSS VAL07C = VAL07C + PNV(5,IN) * SCCSS VAL08C = VAL08C + PNV(6,IN) * SCCSS FIX = NVEC(1,IN) * RBOX(1) FIY = NVEC(2,IN) * RBOX(2) FIZ = NVEC(3,IN) * RBOX(3) DO 152 I = 1, mmole(ijkl) UM(I) = USICOS * ZICOS(I) + USISIN * ZISIN(I) + UM(I) FIJ = FSICOS * ZISIN(I) - FSISIN * ZICOS(I) FM(1,I) = FM(1,I) + FIJ * FIX FM(2,I) = FM(2,I) + FIJ * FIY FM(3,I) = FM(3,I) + FIJ * FIZ 152 CONTINUE 170 CONTINUE VAL09 = VAL09 + VAL09C * 0.5D0 VAL91 = VAL91 + VAL09C * 0.5D0 C C ------------------------------------- Coulomb direct lattice space C 200 RCUT2 = RCUT(1) * RCUT(1) CP AL2PI = 2.0D0 * ALPHA / SQRT(PI) c ------------------ Calculation of Coulomb in a polyatomic molecule DO 392 I = 1, mmole(ijkl)-1 PIX = PM(1,I) PIY = PM(2,I) PIZ = PM(3,I) DO 382 J = I+1, mmole(ijkl) ZIZJ = ZM(I) * ZM(J) pjx0 = pM(1,j) pjy0 = pM(2,j) pjz0 = pM(3,j) if (pjx0.lt.pix) pjx0 = pjx0 + 1.0 if (pjy0.lt.piy) pjy0 = pjy0 + 1.0 if (pjz0.lt.piz) pjz0 = pjz0 + 1.0 DO 252 K = 1, 8 pjx = pjx0 - transx(k) pjy = pjy0 - transy(k) pjz = pjz0 - transz(k) RX = PIX - PjX RY = PIY - PjY RZ = PIZ - PjZ c RX = PIX - PjX c RY = PIY - PjY c RZ = PIZ - PjZ c - - - - - delete these if-statements for triclinic c IF (ABS(RX).GT.0.5) RX = RX - SIGN(1.0D0,RX) c IF (ABS(RY).GT.0.5) RY = RY - SIGN(1.0D0,RY) c IF (ABS(RZ).GT.0.5) RZ = RZ - SIGN(1.0D0,RZ) c DX = H(1,1)*RX + H(1,2)*RY + H(1,3)*RZ c DY = H(2,1)*RX + H(2,2)*RY + H(2,3)*RZ C DZ = H(3,1)*RX + H(3,2)*RY + H(3,3)*RZ DX = RX * BOX(1) DY = RY * BOX(2) DZ = RZ * BOX(3) RIJ2 = DX*DX + DY*DY + DZ*DZ IF (RIJ2.LE.RCUT2) GO TO 257 252 CONTINUE GO TO 262 C 257 RIJ = SQRT(RIJ2) IP0 = INT(RIJ*100.0) C ---------------------------------- Interpolation IP1 = IP0 + 1 IP2 = IP0 + 2 R00 = IP0 * 0.01D0 R01 = IP1 * 0.01D0 R02 = IP2 * 0.01D0 C X0 = (RIJ-R01)*(RIJ-R02)/((R00-R01)*(R00-R02)) C X1 = (RIJ-R00)*(RIJ-R02)/((R01-R00)*(R01-R02)) C X2 = (RIJ-R00)*(RIJ-R01)/((R02-R00)*(R02-R01)) X0 = (RIJ-R01)*(RIJ-R02) * 5000.0 X1 = (RIJ-R00)*(RIJ-R02) * (-10000.0) X2 = (RIJ-R00)*(RIJ-R01) * 5000.0 FIJ = (F0(IP0)*X0 +F0(IP1)*X1 +F0(IP2)*X2)*ZIZJ EIJ = (E0(IP0)*X0 +E0(IP1)*X1 +E0(IP2)*X2)*ZIZJ CE ----------------------- For precise calculations CE ARIJ = 1.0D0 / RIJ C ------ FUNCTION ERFC(X) : VERSION 5662 C ------ in "COMPUTER APPROXIMATIONS" CE Z = ABS(ALPHA * RIJ) CE ERFC = EXP(-Z*Z) * CE * (EX0+Z*(EX1+Z*(EX2+Z*EX3))) / CE * (EY0+Z*(EY1+Z*(EY2+Z*(EY3+Z*EY4))) ) CE EIJ = ERFC * (ARIJ*1.0D8) * ZIJE2 CE FIJ = (AL2PI*EXP(-(ALPHA*RIJ)**2)*RIJ + ERFC) CE * * (ARIJ*1.0D8)**2 * ARIJ *ZIJE2 CE ------------------------------------------------ VAL09 = VAL09 + EIJ VAL92 = VAL92 + EIJ UM(I) = UM(I) + EIJ UM(J) = UM(J) + EIJ DFX = FIJ * DX DFY = FIJ * DY DFZ = FIJ * DZ FM(1,I) = FM(1,I) + DFX FM(2,I) = FM(2,I) + DFY FM(3,I) = FM(3,I) + DFZ FM(1,J) = FM(1,J) - DFX FM(2,J) = FM(2,J) - DFY FM(3,J) = FM(3,J) - DFZ VAL03 = VAL03 + DFX * DX VAL04 = VAL04 + DFY * DY VAL05 = VAL05 + DFZ * DZ VAL06 = VAL06 + DFX * DY VAL07 = VAL07 + DFX * DZ VAL08 = VAL08 + DFY * DZ 262 CONTINUE 382 CONTINUE 392 CONTINUE UI(NTION+IJKL) = UI(NTION+IJKL) - UM(3) FX(NTION+IJKL) = FX(NTION+IJKL) - FM(1,3) FY(NTION+IJKL) = FY(NTION+IJKL) - FM(2,3) FZ(NTION+IJKL) = FZ(NTION+IJKL) - FM(3,3) DO 955 II = 1, mmole(ijkl) I = IDMOLE(II,IJKL) UI(I) = UI(I) - UM(II) FX(I) = FX(I) - FM(1,II) FY(I) = FY(I) - FM(2,II) FZ(I) = FZ(I) - FM(3,II) fx(i) = fx(i) + fx(ntion+ijKL) / 2.0 fy(i) = fy(i) + fy(ntion+ijKL) / 2.0 fz(i) = fz(i) + fz(ntion+ijKL) / 2.0 ui(i) = ui(i) + ui(ntion+ijKL) / 2.0 955 CONTINUE 999 continue C VAL(3) = VAL(3) - VAL03*1.0D-8 - VAL03C VAL(4) = VAL(4) - VAL04*1.0D-8 - VAL04C VAL(5) = VAL(5) - VAL05*1.0D-8 - VAL05C VAL(6) = VAL(6) - VAL06*1.0D-8 - VAL06C VAL(7) = VAL(7) - VAL07*1.0D-8 - VAL07C VAL(8) = VAL(8) - VAL08*1.0D-8 - VAL08C VAL(9) = VAL(9) - VAL09 do ii = MOLstart(1), MOLend(1) VAL(9) = VAL(9) - UCSLFI(II) end do PRSTC2(1) = PRSTC2(1) - VAL03C PRSTC2(2) = PRSTC2(2) - VAL04C PRSTC2(3) = PRSTC2(3) - VAL05C PRSTC2(4) = PRSTC2(4) - VAL06C PRSTC2(5) = PRSTC2(5) - VAL07C PRSTC2(6) = PRSTC2(6) - VAL08C RETURN END C C C ======== C================================================================ THREEP SUBROUTINE THREEP (I,j,k, KK3BP, VIRLSR) PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C C ------------------------------------------- 3-body potential model C COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /VALUES/ TVAL(LVA),TVALL(LVA),VALMAX(LVA),VAL0(LVA), * SVAL(LVA),SVALL(LVA),VALMIN(LVA), * VAL(LVA),AVA(LVA,L50), NAV,NAVT REAL *8 TVAL,SVAL,TVALL,SVALL,VALMAX,VALMIN,VAL0,VAL,AVA COMMON /PARAMT/ AIO(LEM),BIO(LEM),CIO(LEM),DIO(LEM),ZIO(LEM), * AIJ(LEF),BIJ(LEF),CIJ(LEF),DIJ(LEF),D4IJ(LEF), * PLIJ(LEF),RSWTCH(LEF),ZIJ(LEF), D7IJ(LEF), * ECORR,VCORR, WIO(LEM), TWEGHT, AKFI(LEM), * ANG3BP(L3P), R3BLIM(2,L3P), * FK3BP(L3P), R3BGRD(2,L3P), R3lim(2,l3p),r3limax, * I3BP(3,L3P), N3BP COMMON /FORCES/ FX(LNI),FY(LNI),FZ(LNI) REAL *8 FX,FY,FZ COMMON /CONSTS/ PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL REAL *8 PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL C COMMON /DATOMS/ D1ATOM, D1AXYZ(3), ddatom(50,lni), * D2ATOM, D2AXYZ(3), idatom(51,lni) REAL *8 D1ATOM, D1AXYZ, D2ATOM,D2AXYZ C REAL *8 RIJX1,rijx2,DRDX1I,drdx2i,DRDX1J,drdx2j,FFX,DCDX,CDR0, * RIJY1,rijy2,DRDY1I,drdy2i,DRDY1J,drdy2j,FFY,DCDY,CDR1, * RIJZ1,rijz2,DRDZ1I,drdz2i,DRDZ1J,drdz2j,FFZ,DCDZ,CDR2 REAL *8 AK1,rij1,ARIJ1,CDR,EX1,SINJIJ,VAL03, VAL04, VAL05, * AK2,rij2,ARIJ2,CDS,EX2,COSJIJ,VAL06, VAL07, VAL08 real *8 ffx1, ffx2, ASINJ, VIRLSR, PI180 REAL *8 ffy1, ffy2, RM, GR, FACT, RDJIJ, RD0 REAL *8 ffz1, ffz2, FK, UJIJ, PHAI2 C C ---------------------------------------- F = FK3BP * SIN(2*ANG3BP) IF (FK3BP(KK3BP).LE.1.0E-21) RETURN C -------------------------------------------------- I : Central ion C J : J-I-J PI180 = 180.0D0 / PI VAL03 = 0.0D0 VAL04 = 0.0D0 VAL05 = 0.0D0 VAL06 = 0.0D0 VAL07 = 0.0D0 VAL08 = 0.0D0 RM = DBLE(R3BLIM(1,KK3BP)) GR = DBLE(R3BGRD(1,KK3BP)) RD0 = DBLE(ANG3BP(KK3BP)) / PI180 FK = DBLE(FK3BP(KK3BP)) * 1.0D-8 C RIJ1 = D1ATOM ARIJ1 = 1.0D0 / rij1 RIJX1 = - D1AXYZ(1) RIJY1 = - D1AXYZ(2) RIJZ1 = - D1AXYZ(3) DRDX1I = - RIJX1 * ARij1 DRDY1I = - RIJY1 * ARij1 DRDZ1I = - RIJZ1 * ARij1 DRDX1J = RIJX1 * ARij1 DRDY1J = RIJY1 * ARij1 DRDZ1J = RIJZ1 * ARij1 c DO 710 L2 = L1+1, NIJ rij2 = d2atom ARIJ2 = 1.0D0 / rij2 RIJX2 = - D2AXYZ(1) RIJY2 = - D2AXYZ(2) RIJZ2 = - D2AXYZ(3) DRDX2I = - RIJX2 * ARij2 DRDY2I = - RIJY2 * ARij2 DRDZ2I = - RIJZ2 * ARij2 DRDX2J = RIJX2 * ARij2 DRDY2J = RIJY2 * ARij2 DRDZ2J = RIJZ2 * ARij2 c COSJIJ = ( d1axyz(1) * d2axyz(1) + * d1axyz(2) * d2axyz(2) + * d1axyz(3) * d2axyz(3) ) * ARIJ1 * ARIJ2 IF (ABS(COSJIJ).LT.1.0D-11) THEN COSJIJ = SIGN(1.0D-11,COSJIJ) END IF SINJIJ = SQRT(1.0D0 - COSJIJ*COSJIJ) ASINJ = SIGN(1.0D-11,SINJIJ) IF (ABS(SINJIJ).GT.1D-11) ASINJ = 1.0D0 / SINJIJ C --------------------------------------- TJIJ : J-I-J angle RDJIJ = ATAN(SINJIJ / COSJIJ) IF (RDJIJ.LT.0.0D0) RDJIJ = RDJIJ + PI TJIJ = RDJIJ * PI180 IF (TJIJ.LT.0.0) TJIJ = TJIJ + 180.0 C --------------------- Decriment of force with I-J distance EX1 = EXP((d1atom - RM) * GR) EX2 = EXP((d2atom - RM) * GR) AK1 = 1.0D0 / (EX1 + 1.0D0) AK2 = 1.0D0 / (EX2 + 1.0D0) fact = sqrt (ak1*ak2) if (runopt(8).eq.'BMH-EXP* ') FACT = AK1 * AK2 C ----------------------------- FJIJ : Force for J-I-J angle C UJIJ : Potential for J-I-J angle PHAI2 = 2.0D0 * (RDJIJ - RD0) UJIJ = -1.0D0 *FK *(COS(PHAI2) -1.0D0) * FACT VAL(11) = VAL(11) + UJIJ C DCDX = (drdx2j - Drdx1j*COSJIJ) * ARIJ1 DCDY = (drdy2j - Drdy1j*COSJIJ) * ARIJ1 DCDZ = (drdz2j - Drdz1j*COSJIJ) * ARIJ1 CDR = 0.5D0 *AK1 *GR *EX1 *(COS(PHAI2)-1.0D0) if (runopt(8).eq.'BMH-EXP* ') * CDR = AK1 *GR *EX1*(COS(PHAI2)-1.0D0) CDS = -2.0D0 *ASINJ *SIN(PHAI2) FFX1 = -1.0D8 *FK *FACT *(CDR *Drdx1j + CDS *DCDX) FFY1 = -1.0D8 *FK *FACT *(CDR *Drdy1j + CDS *DCDY) FFZ1 = -1.0D8 *FK *FACT *(CDR *Drdz1j + CDS *DCDZ) c J1 = KIJ(L1) FX(J) = FX(J) + FFX1 FY(J) = FY(J) + FFY1 FZ(J) = FZ(J) + FFZ1 VIRLSR = VIRLSR + * FFX1*RIJX1 + FFY1*RIJY1 + FFZ1*RIJZ1 VAL03 = VAL03 + FFX1 *RIJX1 VAL04 = VAL04 + FFY1 *RIJY1 VAL05 = VAL05 + FFZ1 *RIJZ1 VAL06 = VAL06 + FFX1 *RIJY1 VAL07 = VAL07 + FFX1 *RIJZ1 VAL08 = VAL08 + FFY1 *RIJZ1 C DCDX = (DRDX1J - DRDX2J*COSJIJ) * ARIJ2 DCDY = (DRDY1J - DRDY2J*COSJIJ) * ARIJ2 DCDZ = (DRDZ1J - DRDZ2J*COSJIJ) * ARIJ2 CDR = 0.5D0 *AK2 *GR *EX2 *(COS(PHAI2)-1.0D0) if (runopt(8).eq.'BMH-EXP* ') * CDR = AK2 *GR *EX2 *(COS(PHAI2)-1.0D0) C CDS = -2.0D0 *ASINJ *SIN(PHAI2) FFX2 = -1.0D8 *FK *FACT *(CDR *DRDX2J + CDS *DCDX) FFY2 = -1.0D8 *FK *FACT *(CDR *DRDY2J + CDS *DCDY) FFZ2 = -1.0D8 *FK *FACT *(CDR *DRDZ2J + CDS *DCDZ) c J2 = KIJ(L2) FX(k) = FX(k) + FFX2 FY(k) = FY(k) + FFY2 FZ(k) = FZ(k) + FFZ2 VIRLSR = VIRLSR + * FFX2*RIJX2 + FFY2*RIJY2 + FFZ2*RIJZ2 VAL03 = VAL03 + FFX2 *RIJX2 VAL04 = VAL04 + FFY2 *RIJY2 VAL05 = VAL05 + FFZ2 *RIJZ2 VAL06 = VAL06 + FFX2 *RIJY2 VAL07 = VAL07 + FFX2 *RIJZ2 VAL08 = VAL08 + FFY2 *RIJZ2 C DCDX = (DRDX1I - DRDX2I*COSJIJ) * ARIJ2 + * (DRDX2I - DRDX1I*COSJIJ) * ARIJ1 DCDY = (DRDY1I - DRDY2I*COSJIJ) * ARIJ2 + * (DRDY2I - DRDY1I*COSJIJ) * ARIJ1 DCDZ = (DRDZ1I - DRDZ2I*COSJIJ) * ARIJ2 + * (DRDZ2I - DRDZ1I*COSJIJ) * ARIJ1 CDR0 = 0.5D0 * GR * (COS(PHAI2)-1.0D0) if (runopt(8).eq.'BMH-EXP* ') * CDR0 = GR *(COS(PHAI2)-1.0D0) CDR1 = AK1 * EX1 * CDR0 CDR2 = AK2 * EX2 * CDR0 FFX = FK *FACT *(CDR1*DRDX1I + CDR2*DRDX2I +CDS*DCDX) FFY = FK *FACT *(CDR1*DRDY1I + CDR2*DRDY2I +CDS*DCDY) FFZ = FK *FACT *(CDR1*DRDZ1I + CDR2*DRDZ2I +CDS*DCDZ) FFX = FFX * (-1.0D8) FFY = FFY * (-1.0D8) FFZ = FFZ * (-1.0D8) ffx = ffx - (ffx + ffx1 + ffx2) ffy = ffy - (ffy + ffy1 + ffy2) ffz = ffz - (ffz + ffz1 + ffz2) FX(I) = FX(I) + FFX FY(I) = FY(I) + FFY FZ(I) = FZ(I) + FFZ c AV3BP(1,KK3BP) = AV3BP(1,KK3BP) + TJIJ AV3BP(2,KK3BP) = AV3BP(2,KK3BP) + 1.0 C VAL(3) = VAL(3) + VAL03 *1.0D-8 VAL(4) = VAL(4) + VAL04 *1.0D-8 VAL(5) = VAL(5) + VAL05 *1.0D-8 VAL(6) = VAL(6) + VAL06 *1.0D-8 VAL(7) = VAL(7) + VAL07 *1.0D-8 VAL(8) = VAL(8) + VAL08 *1.0D-8 C RETURN END C C C ======= C================================================================ THREEQ SUBROUTINE THREEQ (I,j,k, KK3BP, VIRLSR, * d1atom,d1axyz, d2atom,d2axyz) PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C C ------------------------------ 3-body potential model j-i-k (j Nirin] ----- C PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES(3),PPXYZ(7),FJMOL, * T000,T050, IAXTGR, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES,PPXYZ,FJMOL COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /PARAMT/ AIO(LEM),BIO(LEM),CIO(LEM),DIO(LEM),ZIO(LEM), * AIJ(LEF),BIJ(LEF),CIJ(LEF),DIJ(LEF),D4IJ(LEF), * PLIJ(LEF),RSWTCH(LEF),ZIJ(LEF), D7IJ(LEF), * ECORR,VCORR, WIO(LEM), TWEGHT, AKFI(LEM), * ANG3BP(L3P), R3BLIM(2,L3P), * FK3BP(L3P), R3BGRD(2,L3P), R3lim(2,l3p),r3limax, * I3BP(3,L3P), N3BP COMMON /FORCES/ FX(LNI),FY(LNI),FZ(LNI) REAL *8 FX,FY,FZ COMMON /WORK02/ UUII(LNI),ZII(LNI),ZICOS(LNI),ZISIN(LNI) REAL *8 ZICOS, ZISIN COMMON /CONSTS/ PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL REAL *8 PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL COMMON /OUTERF/ EFD(3), EFREQ, GFD(3), fconvc, MEFD REAL *8 EFD, EFREQ, GFD c REAL *8 FCOUNT,REFREQ,CTIME REAL *8 EFDX,EFDY,EFDZ,DEE REAL *8 fefx,fefy,fefz,ZZZ cccccc C --- MEFD = mode of the electric field --- C 0 ... Static electric field C 1 ... ( 0 to E) pulse C 2 ... (-E to E) pulse C 3 ... saw tooth pulse incomplete C 4 ... sine oscillator C c write(6,*) MEFD, EFREQ c write(6,*) EFD(1),EFD(2),EFD(3) IF (NRECRD(1) .EQ. 1) THEN MSWTCH = 1 FCOUNT = 1.000000D0 END IF IF (EFREQ .NE. 0.00000D0) REFREQ = 1.000D0 / EFREQ CTIME = DTIME*NRECRD(1) PI2 = 2.000D0 * PI IF (MEFD .EQ. 0) THEN EFDX = EFD(1) EFDY = EFD(2) EFDZ = EFD(3) ELSEIF (MEFD .EQ. 1) THEN IF (CTIME .GE. REFREQ*FCOUNT) THEN MSWTCH = -MSWTCH FCOUNT = FCOUNT + 1.000000D0 END IF IF (MSWTCH .GT. 0) THEN EFDX = EFD(1) EFDY = EFD(2) EFDZ = EFD(3) ELSE EFDX = 0.000000D0 EFDY = 0.000000D0 EFDZ = 0.000000D0 END IF ELSEIF (MEFD .EQ. 2) THEN IF (CTIME .GE. REFREQ*FCOUNT) THEN MSWTCH = -MSWTCH FCOUNT = FCOUNT + 1.000000D0 END IF EFDX = EFD(1) * DBLE(MSWTCH) EFDY = EFD(2) * DBLE(MSWTCH) EFDZ = EFD(3) * DBLE(MSWTCH) c ELSEIF (MEFD .EQ. 3) THEN c FREQP4 = EFREQ / 4.000000D0 c ExSLP = EFD(1)/FREQP4 c EySLP = EFD(2)/FREQP4 c EySLP = EFD(3)/FREQP4 c IF (CTIME .GE. FREQP4*FCOUNT) THEN c MSWTCH = -MSWTCH c FCOUNT = FCOUNT + 1.000000D0 c ExSLP = -ExSLP c EySLP = -EySLP c EySLP = -EySLP c END IF c IF (MSWTCH .GT. 0) THEN c EFDX = EFD(1) c EFDY = EFD(2) c EFDZ = EFD(3) c ELSE c EFDX = 0.000000D0 c EFDY = 0.000000D0 c EFDZ = 0.000000D0 c END IF c ELSEIF (MEFD .EQ. 4) THEN DEE = SIN(PI2*EFREQ*CTIME) EFDX = EFD(1)*DEE EFDY = EFD(2)*DEE EFDZ = EFD(3)*DEE c write(6,*) EFDX,EFDY,EFDZ ! check AC END IF C DO I=1,NTION fefx = 0.0000D0 fefy = 0.0000D0 fefz = 0.0000D0 c ZIO =0, or EFD =0 then fef = 0 naturally c ZZZ = ZII(I) * ELC ! esu ZZZ = ZII(I) * 1.60217733D-19 ! Coulomb fefx = EFDX * ZZZ fefy = EFDY * ZZZ fefz = EFDZ * ZZZ C FX(I) = FX(I) + fefx FY(I) = FY(I) + fefy FZ(I) = FZ(I) + fefz END DO END C C C ======== C================================================================ GRAVFD SUBROUTINE GRAVFD C C ---------------------------------------------- Gravity field ----- C PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES(3),PPXYZ(7),FJMOL, * T000,T050, IAXTGR, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES,PPXYZ,FJMOL COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /PARAMT/ AIO(LEM),BIO(LEM),CIO(LEM),DIO(LEM),ZIO(LEM), * AIJ(LEF),BIJ(LEF),CIJ(LEF),DIJ(LEF),D4IJ(LEF), * PLIJ(LEF),RSWTCH(LEF),ZIJ(LEF), D7IJ(LEF), * ECORR,VCORR, WIO(LEM), TWEGHT, AKFI(LEM), * ANG3BP(L3P), R3BLIM(2,L3P), * FK3BP(L3P), R3BGRD(2,L3P), R3lim(2,l3p),r3limax, * I3BP(3,L3P), N3BP COMMON /FORCES/ FX(LNI),FY(LNI),FZ(LNI) REAL *8 FX,FY,FZ COMMON /CONSTS/ PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL REAL *8 PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL COMMON /OUTERF/ EFD(3), EFREQ, GFD(3), fconvc, MEFD REAL *8 EFD, EFREQ, GFD c REAL *8 GFDX, GFDY, GFDZ c C ------ g = 9.80665 m/s2 = 980.665 cm/s2 g = 980.665 c c write(6,*) 'Gravity field ', GFD GFDX = GFD(1) * g GFDY = GFD(2) * g GFDZ = GFD(3) * g c c write (6,*) fx(1),fy(1),fz(1) c write (6,*) gfdx*wio(1)/ana,gfdy*wio(1)/ana,gfdz*wio(1)/ana do io = 1, ncompo w = wio(io) / ANA DO I = ions(1,io), ions(2,io) FX(I) = FX(I) - w * gfdx FY(I) = FY(I) - w * gfdy FZ(I) = FZ(I) - w * gfdz END DO end do END C C C ============= C=========================================================== Wall at z=0 SUBROUTINE WALL C C ---------------------------------------------- Gravity field ----- C PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES(3),PPXYZ(7),FJMOL, * T000,T050, IAXTGR, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES,PPXYZ,FJMOL COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /PARAMT/ AIO(LEM),BIO(LEM),CIO(LEM),DIO(LEM),ZIO(LEM), * AIJ(LEF),BIJ(LEF),CIJ(LEF),DIJ(LEF),D4IJ(LEF), * PLIJ(LEF),RSWTCH(LEF),ZIJ(LEF), D7IJ(LEF), * ECORR,VCORR, WIO(LEM), TWEGHT, AKFI(LEM), * ANG3BP(L3P), R3BLIM(2,L3P), * FK3BP(L3P), R3BGRD(2,L3P), R3lim(2,l3p),r3limax, * I3BP(3,L3P), N3BP COMMON /FORCES/ FX(LNI),FY(LNI),FZ(LNI) REAL *8 FX,FY,FZ COMMON /CONSTS/ PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL REAL *8 PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL COMMON /OUTERF/ EFD(3), EFREQ, GFD(3), fconvc, MEFD REAL *8 EFD, EFREQ, GFD common /WALLP/ WALLa, WALLb c BETA = CAL * 1.0D10 / ANA c write (6,*) 'wall',walla,wallb c do io = 1, ncompo aw = walla + aio(io) bw = wallb + bio(io) c write (6,*) io,aw,bw DO I = ions(1,io), ions(2,io) riz = P(3,i)*BOX(3) Fz(I) = Fz(I) + beta * exp((aw-riz)/bw) UI(I) = UI(I) + beta * bw * exp((aw-riz)/bw) END DO end do END C C C ======= C================================================================ SCCELL SUBROUTINE SCCELL (PXYZ) PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C C -------------------------- Basic cell scaling for pressure control C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES(3),PPXYZ(7),FJMOL, * T000,T050, IAXTGR, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /CARTES/ H(3,3),HINV(3,3),FTOQ(3,3),RBOX(6), * G(3,3),GINV(3,3),TRANSX(8),TRANSY(8),TRANSZ(8) CT * ,Q(3,LNI),Q0(3,LNI) REAL *8 H,HINV,G,GINV,FTOQ,RBOX,TRANSX,TRANSY,TRANSZ COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME C REAL *8 PXYZ(7) REAL *8 FA(3), FK, DVOO, DVO, DFV, DAL(3), DDD C IF (RUNOPT(6).NE.'P SCALING ' .AND. * RUNOPT(7).NE.'D CONST. ' ) RETURN C 100 APXYZ = (PXYZ(2) + PXYZ(3) + PXYZ(4)) / 3.0 APXYZ = PXYZ(1) - APXYZ PXYZ(2) = PXYZ(2) + APXYZ PXYZ(3) = PXYZ(3) + APXYZ PXYZ(4) = PXYZ(4) + APXYZ C ASPRES = (SPRES(1) + SPRES(2) + SPRES(3)) / 3.0 FLMT = 1.0 / (1.0 + ASPRES/25.0) IF (VBOX(1).LT.1.0E-5) VBOX(1) = 1.0 DO 30 I = 1, 3 DP = PXYZ(I+1) - PPXYZ(I+1) DPP = PXYZ(I+1) - SPRES(I) IF (DP*DPP.GT.0.0) VBOX(1) = VBOX(1) / 1.05 IF (DP*DPP.LT.0.0) VBOX(1) = VBOX(1) * 1.05 30 CONTINUE IF (VBOX(1).LT.0.10) VBOX(1) = 0.10 IF (VBOX(1).GT.FLMT) VBOX(1) = FLMT C 50 DVOO = 1.0D0 DDD = 0.001D0 * 512.0D0 DO 70 I = 1, 3 DVOO = DVOO * BOX(I) FK = ATAN((PXYZ(I+1) - SPRES(I))*VBOX(1)*DDD) / 512.0D0 FA(I) = 1.0D0 + FK*PDUMP BOX(I) = BOX(I) * FA(I) DAL(I) = BOX(I) DO 70 J = 1, 3 H(J,I) = H(J,I) * FA(I) 70 CONTINUE DO 80 I = 1, 7 PPXYZ(I) = PXYZ(I) 80 CONTINUE C IF (RUNOPT(7).EQ.'D CONST. ') THEN DVO = DAL(1) * DAL(2) * DAL(3) DFV = (DVOO / DVO)**(1.0/3.0) DO 90 I = 1, 3 BOX(I) = DAL(I) * DFV DO 90 J = 1, 3 H(J,I) = H(J,I) * DFV 90 CONTINUE END IF C CALL TABLER (0) RETURN END C C C ======== C=============================================================== RECORD9 SUBROUTINE RECORD9 PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C C ------------------------------------------------- Out put FILE09's C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES(3),PPXYZ(7),FJMOL, * T000,T050, IAXTGR, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME COMMON /VALUES/ TVAL(LVA),TVALL(LVA),VALMAX(LVA),VAL0(LVA), * SVAL(LVA),SVALL(LVA),VALMIN(LVA), * VAL(LVA),AVA(LVA,L50), NAV,NAVT REAL *8 TVAL,SVAL,TVALL,SVALL,VALMAX,VALMIN,VAL0,VAL,AVA COMMON /RADIAL/ NRDF(LTB,LEE),IPRDF(2) INTEGER *4 NRDF COMMON /GEOMET/ DTO(2),AVTHT(12),MBR(8,8,2),NRG(9,2),ITBR(121,12), * RTO(2),SVTHT(12),NBR(8,8,2),MEB(9,2), NTT(121,12), * NTO(2),NVTHT(12),ANGL(3,12),TTAB(LST), NTBL, * ANCN(7,2) COMMON /ACOORD/ NPT, BOXO(6),NIU(LAA),P0C(3,LAT),NSYM,ISYM(LNI), * NPTP,NBOX(3),JON(LAT),PPC(3,LAT),MATM, * RS(3,3,96),PPS(3,LAT),IHEX COMMON /WORK01/ VV(3,LNI), PPK(3,LNI) COMMON /WORK02/ IP(3,LNI), JPS(3,LNI) C REAL *4 UIUI(LNI) REAL *8 SSS CHARACTER *10 DUMMY DUMMY = ' ' C ----------------------------------------------------------- Values IF (NRECRD(1).EQ.1) THEN DO 780 I = 1, LVA VAL0(I) = VAL(I) 780 CONTINUE END IF NAVT = NAVT + 1 DO 790 I = 1, LVA SSS = VAL(I) - VAL0(I) TVALL(I) = TVALL(I) + SSS SVALL(I) = SVALL(I) + SSS*SSS IF (VALMAX(I).LT.VAL(I)) VALMAX(I) = VAL(I) IF (VALMIN(I).GT.VAL(I)) VALMIN(I) = VAL(I) 790 CONTINUE C --------------------------------------------------- FILE09P for MD IF (RUNOPT(17).EQ.'AMORPHOUS ') THEN IF (TITLE(1).NE.'BENC' .OR. * TITLE(2).NE. 'HMAR' ) THEN IF (MOD(NRECRD(1),IRECRD(4)).EQ.0) THEN NRECRD(4) = NRECRD(4) + 1 IF (RUNOPT(18).EQ.'BINARY ') THEN WRITE (19) NRECRD(4), BOX(1), 0.0, 0.0, 0.0, * BOX(2), 0.0, 0.0, 0.0, BOX(3) WRITE (19) ((SNGL(P(J,I)),J=1,3),I=1,NTION) ELSE DO 810 I = 1, NTION DO 810 J = 1, 3 IP(J,I) = P(J,I) * 9000.0 810 CONTINUE WRITE (19,9001) NRECRD(4), BOX(1), * 0.0, 0.0, 0.0, BOX(2), * 0.0, 0.0, 0.0, BOX(3) WRITE (19,9002) ((IP(J,I),J=1,3),I=1,NTION) END IF END IF END IF END IF C -------------------------------------------- Coordinates for XD IF (RUNOPT(17).EQ.'CRYSTAL ') THEN DO 840 I = 1, NPTP KON = JON(I) DO 820 J = 1, 3 PK = P(J,KON) DPK = PK - P0C(J,I) / NBOX(J) IF (DPK.GT. 0.5) PK = PK - 1.0 IF (DPK.LT.-0.5) PK = PK + 1.0 PPK(J,I) = PK JPS(J,I) = PK*9000 if (jps(j,i).le.-1000) jps(j,i)=jps(j,i)+10000 if (jps(j,i).ge.10000) jps(j,i)=jps(j,i)-10000 IF (I.LE.NPT) THEN PK = PK * NBOX(J) PPC(J,I) = PPC(J,I) + PK PPS(J,I) = PPS(J,I) + PK*PK END IF 820 CONTINUE 840 CONTINUE C ------------------------------------------ FILE09P for XD IF (TITLE(1).NE.'BENC' .OR. * TITLE(2).NE. 'HMAR' ) THEN IF (MOD(NRECRD(1),IRECRD(4)).EQ.0) THEN NRECRD(4) = NRECRD(4) + 1 DUMMY = 'POSITION' IF (RUNOPT(18).EQ.'BINARY ') THEN WRITE (19) NRECRD(4), BOX(1), 0.0, 0.0, 0.0, * BOX(2), 0.0, 0.0, 0.0, BOX(3) WRITE (19) ((PPK(J,I),J=1,3),I=1,NPTP) ELSE WRITE (19,9001) NRECRD(4), BOX(1), * 0.0, 0.0, 0.0, BOX(2), * 0.0, 0.0, 0.0, BOX(3) WRITE (19,9002) ((JPS(J,I),J=1,3),I=1,NPTP) END IF END IF END IF END IF C ------------------------------------------------------- FILE09V IF (MOD(NRECRD(1),IRECRD(5)).EQ.0) THEN NRECRD(5) = NRECRD(5) + 1 IF (TITLE(1).NE.'BENC' .OR. * TITLE(2).NE. 'HMAR' ) THEN WRITE (29,1991) VAL 1991 FORMAT (F8.2,7F8.4 / 8F9.2 / * F9.5, F9.3, 3F9.5,3F9.5 / * 10F8.2 / 10F8.3 ) END IF END IF C ------------------------------------------------------ FILE09PV IF (RUNOPT(11).NE.' ') THEN NRECRD(9) = NRECRD(9) + 1 IF (TITLE(1).EQ.'BENC' .AND. * TITLE(2).EQ. 'HMAR' ) RETURN IF (RUNOPT(11).EQ.'VELOCITY ') THEN IF (MOD(NRECRD(1),IRECRD(9)).EQ.0) THEN IF (RUNOPT(18).EQ.'BINARY ') THEN DO 905 I = 1, NTION DO 905 J = 1, 3 VV(J,I) = V(J,I) / DTIME 905 CONTINUE WRITE(28) NRECRD(1) WRITE(28) ((VV(J,I),J=1,3),I=1,NTION) ELSE DO 910 I = 1, NTION DO 910 J = 1, 3 IP(J,I)=V(J,I)*PVMULT*1E-15 /DTIME+5000.0 910 CONTINUE WRITE(28,9001) NRECRD(1) WRITE(28,9002)((IP(J,I),J=1,3),I=1,NTION) END IF END IF END IF IF (RUNOPT(11).EQ.'POSITION ') THEN IF (MOD(NRECRD(1),IRECRD(9)).EQ.0) THEN IF (RUNOPT(18).EQ.'BINARY ') THEN WRITE (28) NRECRD(1), BOX(1),0.0,0.0,0.0, * BOX(2),0.0,0.0, 0.0, BOX(3) WRITE (28) ((SNGL(P(J,I)),J=1,3),I=1,NTION) ELSE DO 920 I = 1, NTION DO 920 J = 1, 3 IP(J,I) = P(J,I) * PVMULT 920 CONTINUE WRITE(28,9001) NRECRD(1), BOX(1), * 0.0,0.0,0.0,BOX(2),0.0, * 0.0, 0.0, BOX(3) WRITE(28,9002)((IP(J,I),J=1,3),I=1,NTION) END IF END IF END IF IF (RUNOPT(11).EQ.'ENERGY ') THEN IF (MOD(NRECRD(1),IRECRD(9)).EQ.0) THEN DO 930 I = 1, NTION UIUI(I) = UI(I) * PVMULT 930 CONTINUE WRITE(28,9001) NRECRD(1), BOX(1), * 0.0,0.0,0.0,BOX(2),0.0, * 0.0, 0.0, BOX(3) WRITE(28,9003)(UIUI(I),I=1,NTION) END IF END IF IF (RUNOPT(11).EQ.'POSVELENE ') THEN IF (MOD(NRECRD(1),IRECRD(9)).EQ.0) THEN DO 940 I = 1, NTION vv(1,i) = v(1,i)*1E-15 /DTIME vv(2,i) = v(2,i)*1E-15 /DTIME vv(3,i) = v(3,i)*1E-15 /DTIME UIUI(I) = UI(I) * PVMULT 940 CONTINUE WRITE(28,9001) NRECRD(1), BOX(1), * 0.0,0.0,0.0,BOX(2),0.0, * 0.0, 0.0, BOX(3) do 945 i = 1, ntion WRITE (28,9004) (P(j,i),j=1,3), * (Vv(j,i),j=1,3), UIUI(I) 945 continue END IF END IF END IF C ---------------------------------------- Pressure tensor FILE11 IF (RUNOPT(19).EQ.'PRESSURE ') THEN WRITE (27,2013) (VAL(J),J=2,8) 2013 FORMAT (7F9.4) END IF RETURN C 9001 FORMAT (I7,3x,9F7.3) 9002 FORMAT (18I4) 9003 FORMAT (10F8.2) 9004 FORMAT (3F7.5,1X,3F8.6,1X,F8.4) END C C C ======== C================================================================ INTVAL SUBROUTINE INTVAL PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C C --------------------------------------- Print average values, etc. C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES(3),PPXYZ(7),FJMOL, * T000,T050, IAXTGR, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /PARAMT/ AIO(LEM),BIO(LEM),CIO(LEM),DIO(LEM),ZIO(LEM), * AIJ(LEF),BIJ(LEF),CIJ(LEF),DIJ(LEF),D4IJ(LEF), * PLIJ(LEF),RSWTCH(LEF),ZIJ(LEF), D7IJ(LEF), * ECORR,VCORR, WIO(LEM), TWEGHT, AKFI(LEM), * ANG3BP(L3P), R3BLIM(2,L3P), * FK3BP(L3P), R3BGRD(2,L3P), R3lim(2,l3p),r3limax, * I3BP(3,L3P), N3BP COMMON /VALUES/ TVAL(LVA),TVALL(LVA),VALMAX(LVA),VAL0(LVA), * SVAL(LVA),SVALL(LVA),VALMIN(LVA), * VAL(LVA),AVA(LVA,L50), NAV,NAVT REAL *8 TVAL,SVAL,TVALL,SVALL,VALMAX,VALMIN,VAL0,VAL,AVA COMMON /RADIAL/ NRDF(LTB,LEE),IPRDF(2) INTEGER *4 NRDF COMMON /GEOMET/ DTO(2),AVTHT(12),MBR(8,8,2),NRG(9,2),ITBR(121,12), * RTO(2),SVTHT(12),NBR(8,8,2),MEB(9,2), NTT(121,12), * NTO(2),NVTHT(12),ANGL(3,12),TTAB(LST), NTBL, * ANCN(7,2) COMMON /ACOORD/ NPT, BOXO(6),NIU(LAA),P0C(3,LAT),NSYM,ISYM(LNI), * NPTP,NBOX(3),JON(LAT),PPC(3,LAT),MATM, * RS(3,3,96),PPS(3,LAT),IHEX COMMON /QUANCO/ Q1U1(LSR,LEE),Q2U1(LSR,LEE), * TQCE,QCEE,QCIT,QCEF,TEMPQH,TEMPQQ REAL *8 TQCE,QCEE,QCIT,QCEF COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME COMMON /CONSTS/ PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL REAL *8 PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL C CHARACTER *8 SYMB(2) CHARACTER *21 STRING CHARACTER *40 FMT1(2),FMT11,FMT12, FMT2(3),FMT21,FMT22,FMT23 EQUIVALENCE (FMT1(1),FMT11),(FMT1(2),FMT12), * (FMT2(1),FMT21),(FMT2(2),FMT22),(FMT2(3),FMT23) REAL *8 TVV(LVA),TSS(LVA) INTEGER *4 ISDV(11),IVMIN(11),ITSS(11),IAVA(11),ITVV(11), * IVMAX(11) REAL *8 X, Y DATA SYMB / 'MAX. ', 'MIN. '/ STD(X,Y,I) = SQRT(ABS(X - Y*(Y/DBLE(I))) / DBLE(I)) C NAV = NAV + 1 DO 110 I = 1, LVA TVAL(I) = TVAL(I) + TVALL(I) SVAL(I) = SVAL(I) + SVALL(I) SVALL(I) = STD(SVALL(I),TVALL(I),IRECRD(3)) TVALL(I) = TVALL(I) / REAL(IRECRD(3)) + VAL0(I) AVA(I,NAV) = TVALL(I) 110 CONTINUE DO 120 I = 1, LEM IAVA(I) = INT(TVALL(24+I)) ISDV(I) = INT(SVALL(24+I)) 120 CONTINUE IAVA(11) = INT(TVALL(1)) ISDV(11) = INT(SVALL(1)) C IF (RUNOPT(3).NE.'ECONOMY ') WRITE (16,2100) C ------------------------------------- Each nrecrd() step on screen FMT11 = '(1X,A3,I6,F7.4,1H(,3F5.2,1H),' FMT12 = ' F9.1,F8.1,F6.1,F9.1,F8.5 ) ' IF (ABS(TVALL(2)).GT.9.5.AND.ABS(TVALL(2)).LE.95.0) THEN FMT11 = '(1X,A3,I6,F7.3,1H(,3F5.1,1H),' ELSE IF (ABS(TVALL(2)).GT.95.0) THEN FMT11 = '(1X,A3,I6,F7.2,1H(,3F5.0,1H),' END IF IF (ABS(TVALL(9)).LT.1.0D4.AND.ABS(TVALL(14)).LT.1.0D4) THEN FMT12 = ' F9.2,F8.2,F6.2,F9.2,F8.5 ) ' END IF WRITE (*,4001) WRITE (*,FMT1) 'Avr',IAVA(11),(TVALL(J),J=2,5),TVALL(9),TVALL(10), * TVALL(11),TVALL(14),TVALL(17) WRITE (*,FMT1) 'Std',ISDV(11),(SVALL(J),J=2,5),SVALL(9),SVALL(10), * SVALL(11),SVALL(14),SVALL(17) WRITE (*,4001) write (*,2400) (ATOM(j),IAVA(j),j=1,ncompo) 2400 format (1x,'Temperatures:',8(1X,A2,':',I4)) write (*,4001) 4001 FORMAT ( 80('-') ) C --------------------------------- Each nrecrd() step on file06.dat FMT11 = '(I5, 5I5,F8.4,1H(,6F6.3,1H), ' FMT12 = ' F10.2,F9.2,2F7.2,F10.3, F9.5 ) ' FMT21 = '(i3,3H0K+,I4,4I5,F8.4,1H(,6F6.3,1H),' FMT22 = ' F10.2,F9.2,2F7.2,F10.3, F9.5 ) ' FMT23 = ' ' IF (ABS(TVALL(2)).GT.9.0.AND.ABS(TVALL(2)).LT.95.0) THEN FMT11 = '(I5, 5I5,F8.3,1H(,6F6.2,1H), ' FMT21 = '(i3,3H0K+,I4,4I5,F8.3,1H(,6F6.2,1H),' ELSE IF (ABS(TVALL(2)).GE.95.0) THEN FMT11 = '(I5, 5I5,F8.2,1H(,6F6.1,1H), ' FMT21 = '(i3,3H0K+,I4,4I5,F8.2,1H(,6F6.1,1H),' END IF IF (ABS(TVALL(9)).LT.1.0D4.AND.ABS(TVALL(14)).LT.1.0D4) THEN FMT12 = ' F10.3,F9.3,2F7.3,F10.4, F9.5 ) ' FMT22 = ' F10.3,F9.3,2F7.3,F10.4, F9.5 ) ' END IF mmm = NRECRD(1)/100000 WRITE (16,FMT1) mod(NRECRD(1),100000), * (IAVA(I),I=1,4),IAVA(11),(TVALL(J),J=2,11), * TVALL(13),TVALL(14),TVALL(17) WRITE (16,FMT2) mmm, (ISDV(I),I=1,4), ISDV(11), * (SVALL(J),J=2,11), SVALL(13), SVALL(14), * SVALL(17) C NN = IRECRD(2)/IRECRD(3) MM = MOD(NRECRD(1)/IRECRD(3), NN) MJ = 2 IF (RUNOPT(3).EQ.'ECONOMY ') MJ = 10 IF (MOD(MM,MJ).NE.0) RETURN C DO 150 I = 1, LVA TSS(I) = STD(SVAL(I),TVAL(I),NAVT) TVV(I) = TVAL(I) / REAL(NAVT) + VAL0(I) 150 CONTINUE DO 160 I = 1, LEM IVMAX(I) = INT(VALMAX(24+I)) IVMIN(I) = INT(VALMIN(24+I)) ITSS(I) = INT(TSS(24+I)) ITVV(I) = INT(TVV(24+I)) 160 CONTINUE IVMAX(11) = INT(VALMAX(1)) IVMIN(11) = INT(VALMIN(1)) ITSS(11) = INT(TSS(1)) ITVV(11) = INT(TVV(1)) C C --------------------------------------------------- Min and max WRITE (16,2105) FMT11 = '(1X,A4, 5I5,F8.4,1H(,6F6.3,1H), ' IF (ABS(TVALL(2)).GT.9.0.AND.ABS(TVALL(2)).LT.95.0) THEN FMT11 = '(1X,A4, 5I5,F8.3,1H(,6F6.2,1H), ' ELSE IF (ABS(TVALL(2)).GE.95.0) THEN FMT11 = '(1X,A4, 5I5,F8.2,1H(,6F6.1,1H), ' END IF WRITE (16,FMT1) SYMB(1), (IVMAX(I),I=1,4),IVMAX(11), * (VALMAX(J),J= 2,11),VALMAX(13), * VALMAX(14),VALMAX(17) WRITE (16,FMT1) SYMB(2), (IVMIN(I),I=1,4),IVMIN(11), * (VALMIN(J),J= 2,11),VALMIN(13), * VALMIN(14),VALMIN(17) C ------------------------------ Each nrecrd() step in file06.dat FMT11 = '(I5,5I5,F8.4,1H(,6F6.3,1H), ' IF (ABS(TVALL(2)).GT.9.0.AND.ABS(TVALL(2)).LT.95.0) THEN FMT11 = '(I5,5I5,F8.3,1H(,6F6.2,1H), ' ELSE IF (ABS(TVALL(2)).GE.95.0) THEN FMT11 = '(I5,5I5,F8.2,1H(,6F6.1,1H), ' END IF mmm = NAVT / 100000 WRITE (16,2105) WRITE (16,FMT1) mod(NAVT,100000), (ITVV(I),I=1,4),ITVV(11), * (TVV(J),J=2,11),TVV(13),TVV(14),TVV(17) WRITE (16,FMT2) mmm, (ITSS(I),I=1,4),ITSS(11), * (TSS(J),J=2,11),TSS(13),TSS(14),TSS(17) WRITE (16,2105) if (NCOMPO.GT.4) then write (16,2500) (ATOM(j),TVV(24+j),j=1,ncompo) 2500 format (' Temperatures:',10(2X,A2,':',F6.1)) WRITE (16,2105) end if WRITE (16,2880) VCORR/(3.0D0*VOL*1.0D-24)*1.0D-10,ECORR*FJMOL 2880 FORMAT (8X,'Corrections for van der Waals interactions ', * '(approx.) : Pcorr=',F8.4,' GPa',9X,'Ecorr(short)=', * F8.3,' kJ/mol') IF (RUNOPT(12).EQ.'QUANTUM ') THEN WRITE (16,2990) TEMPQH/NAVT 2990 FORMAT (8X,'Effective temperature in quantum correction', * ' is ',F7.2, ' K') END IF WRITE (16,2105) C C ------------------------------------------ Basic cell edge lengths WRITE (16,4038) 4038 FORMAT (1X) WRITE (16,4039) 4039 FORMAT ('I',74('-'),'I') STRING = '[ MD basic cell ] ' IF (RUNOPT(17).EQ.'CRYSTAL ') STRING = '[ crystal unit cell ]' WRITE (16,4000) STRING, * (TVALL(I), SVALL(I), VALMIN(I), VALMAX(I), * I=19,21) 4000 FORMAT ('I Cell dimensions (Angstrom, degree)',10X,A21,8X,'I' * /'I A:', F9.5,' (+-',F7.5,') ',F9.5,' -',F9.5,5X, * 'Alpha: 90.0 (fixed) I', * /'I B:', F9.5,' (+-',F7.5,') ',F9.5,' -',F9.5,5X, * 'Beta : 90.0 (fixed) I', * /'I C:', F9.5,' (+-',F7.5,') ',F9.5,' -',F9.5,5X, * 'Gamma: 90.0 (fixed) I' ) C --------------------------------------------------------- Energies WRITE (16,4039) WRITE (16,4030) TVV(12),TSS(12), TVV(14),TSS(14), * TVV(13),TSS(13), TVV(16),TSS(16), * TVV(15),TSS(15), TVV(18),TSS(18) 4030 FORMAT ('I U =',F11.4, '(',F7.4,')kJ/mol E = U+K =',F12.4, * '(',F7.4,')kJ/mol I' / * 'I K =',F11.4, '(',F7.4,')kJ/mol H = E+PV=',F12.4, * '(',F7.4,')kJ/mol I' / * 'I PV=',F11.4,'(',F7.4,')kJ/mol ', * 'Molar volume=',F10.4,'(',F7.4,')cm3/mol I') WRITE (16,4039) C ---------------------------------------- Mean square displacements FL = 1 DO 405 I = 1, 10 IF (VALMAX(I+34).GE.10.0) FL = 10 IF (VALMAX(I+34).GE.100.0) FL = 100 IF (VALMAX(I+34).GE.100.0) FL = 1000 405 CONTINUE FMT21 = '(8HI M.s.d. ' FMT22 = '2(3X,A2, 1H:, F6.3, 1H(, F5.3,1H), ' FMT23 = ' F6.3,1H-, F6.3,1X), 2H I ) ' IF (FL.GE.10) THEN FMT22 = '2(3X,A2, 1H:, F6.2, 1H(, F5.2,1H), ' FMT23 = ' F6.2,1H-, F6.2,1X), 2H I ) ' END IF IF (FL.GE.100) THEN FMT22 = '2(3X,A2, 1H:, F6.1, 1H(, F5.2,1H), ' FMT23 = ' F6.1,1H-, F6.1,1X), 2H I ) ' END IF WRITE (16,FMT2) (ATOM(I),TVALL(I+34),SVALL(I+34),VALMIN(I+34), * VALMAX(I+34),I=1,2) FMT21 = '(8HI , ' DO 410 II = 1, 4 IF (NCOMPO.GT.II*2) WRITE (16,FMT2) (ATOM(I),TVALL(I+34), * SVALL(I+34),VALMIN(I+34),VALMAX(I+34),I=II*2+1,II*2+2) 410 CONTINUE WRITE (16,4039) C ------------------------------------------------------------------ DO 190 I = 1, LVA VALMIN(I) = 9.9D19 VALMAX(I) =-9.9D19 190 CONTINUE RETURN C 2100 FORMAT (132('-')) 2105 FORMAT (132('=')) END C C C ======== C =========================================================== SUMMRY SUBROUTINE SUMMRY PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C C --------------------------------------- Print average values, etc. C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES(3),PPXYZ(7),FJMOL, * T000,T050, IAXTGR, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /VALUES/ TVAL(LVA),TVALL(LVA),VALMAX(LVA),VAL0(LVA), * SVAL(LVA),SVALL(LVA),VALMIN(LVA), * VAL(LVA),AVA(LVA,L50), NAV,NAVT REAL *8 TVAL,SVAL,TVALL,SVALL,VALMAX,VALMIN,VAL0,VAL,AVA COMMON /RADIAL/ NRDF(LTB,LEE),IPRDF(2) INTEGER *4 NRDF COMMON /GEOMET/ DTO(2),AVTHT(12),MBR(8,8,2),NRG(9,2),ITBR(121,12), * RTO(2),SVTHT(12),NBR(8,8,2),MEB(9,2), NTT(121,12), * NTO(2),NVTHT(12),ANGL(3,12),TTAB(LST), NTBL, * ANCN(7,2) COMMON /ACOORD/ NPT, BOXO(6),NIU(LAA),P0C(3,LAT),NSYM,ISYM(LNI), * NPTP,NBOX(3),JON(LAT),PPC(3,LAT),MATM, * RS(3,3,96),PPS(3,LAT),IHEX COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME COMMON /CONSTS/ PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL REAL *8 PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL C CHARACTER *8 HEAD(2) CHARACTER *40 FMT1(2),FMT11,FMT12 EQUIVALENCE (FMT1(1),FMT11), (FMT1(2),FMT12) C REAL *8 X, Y DATA HEAD / 'AVE' , 'SGM'/ STD(X,Y,I) = SQRT(ABS(X - Y*(Y/DBLE(I))) / DBLE(I)) C IF (IRECRD(1).LE.0) RETURN C WRITE (16,2000) WRITE (16,2100) WRITE (16,2452) 2452 FORMAT (' NS Temp P/GPa ( Pxx, Pyy, Pzz, Pxy, ', * 'Pxz, Pyz ) U:Coulomb Short 3-body Kinet. ', * 'Total Density Cell parameters (A)') WRITE (16,2100) DO 210 I = 1, NAV AVA2I = ABS(AVA(2,I)) FMT11 = '(I4, F7.1, F8.4,1H(,6F6.3,1H), ' FMT12 = 'F10.2,F9.2,2F7.2,F9.2, F8.5,1X,3F8.4) ' IF (AVA2I.GT.9.0 .AND. AVA2I.LT.95.0) THEN FMT11 = '(I4, F7.1, F8.3,1H(,6F6.2,1H), ' ELSE IF (AVA2I.GE.95.0) THEN FMT11 = '(I4, F7.1, F8.2,1H(,6F6.1,1H), ' END IF IF (ABS(AVA(9,I)).LT.1.0D4.AND.ABS(AVA(14,I)).LT.1.0D4) THEN FMT12 = 'F10.3,F9.3,2F7.3,F9.3, F8.5,1X,3F8.4) ' END IF WRITE (16,FMT1) I,(AVA(J,I),J=1,11), AVA(13,I), AVA(14,I), * AVA(17,I),(AVA(J,I),J=19,21) 210 CONTINUE C DO 220 I = 1, LVA SVAL(I) = STD(SVAL(I),TVAL(I),NAVT) TVAL(I) = TVAL(I) / REAL(NAVT) + VAL0(I) 220 CONTINUE WRITE (16,2100) C TVAL2 = ABS(TVAL(2)) FMT11 = '(1X,A3, F7.1, F8.4,1H(,6F6.3,1H), ' FMT12 = 'F10.2,F9.2,2F7.2,F9.2, F8.5,1X,3F8.4)' IF (TVAL2.GT.9.0 .AND. TVAL2.LT.95.0) THEN FMT11 = '(1X,A3, F7.1, F8.3,1H(,6F6.2,1H), ' ELSE IF (TVAL2.GE.95.0) THEN FMT11 = '(1X,A3, F7.1, F8.2,1H(,6F6.1,1H), ' END IF IF (ABS(TVAL(9)).LT.1.0D4.AND.ABS(TVAL(14)).LT.1.0D4) THEN FMT12 = 'F10.3,F9.3,2F7.3,F9.3, F8.5,1X,3F8.4)' END IF WRITE (16,FMT1) HEAD(1),(TVAL(J),J=1,11),TVAL(13),TVAL(14), * TVAL(17), (TVAL(J),J=19,21) WRITE (16,FMT1) HEAD(2),(SVAL(J),J=1,11),SVAL(13),SVAL(14), * SVAL(17), (SVAL(J),J=19,21) WRITE (16,2100) C --------------------------------------------------------- Energies WRITE (16,4038) 4038 FORMAT (1X) WRITE (16,4039) 4039 FORMAT ('I',75('-'),'I') WRITE (16,4030) TVAL(12),SVAL(12), TVAL(14),SVAL(14), * TVAL(13),SVAL(13), TVAL(16),SVAL(16), * TVAL(15),SVAL(15), TVAL(18),SVAL(18) 4030 FORMAT ('I U =',F11.4, '(',F7.4,')kJ/mol E = U+K =',F12.4, * '(',F7.4,')kJ/mol I' / * 'I K =',F11.4, '(',F7.4,')kJ/mol H = E+PV=',F12.4, * '(',F7.4,')kJ/mol I' / * 'I PV=',F11.4,'(',F7.4,')kJ/mol ', * 'Molar volume=',F10.4,'(',F7.4,')cm3/mol I') WRITE (16,4039) C ----------------------------------------------------------- M.s.d. WRITE (16,4020) (ATOM(I),TVAL(I+34),SVAL(I+34),I=1,2) 4020 FORMAT ('I Mean sq.disp. ',2(5X,A2,':',F8.3,' (+-',F6.3,')'), * ' I' ) DO 410 II = 1, 4 IF (NCOMPO.GT.II*2) WRITE (16,4022) (ATOM(I),TVAL(I+34), * SVAL(I+34),I=II*2+1,II*2+2) 4022 FORMAT ('I',16X,2(5X,A2,':',F8.3,' (+-',F6.3,')'),5X,'I' ) 410 CONTINUE WRITE (16,4039) C ------------------------------------------------------------------ WRITE (16,4050) TVAL(1), TVAL(2), TVAL(12),TVAL(13),TVAL(14), * TVAL(15),TVAL(16),TVAL(17),TVAL(18), * SVAL(1), SVAL(2), SVAL(12),SVAL(13),SVAL(14), * SVAL(15),SVAL(16),SVAL(17),SVAL(18), * TVAL(1),TVAL(2),(TVAL(I),I=19,24), * SVAL(1),SVAL(2),(SVAL(I),I=19,24) 4050 FORMAT (/ 78('=') / ' T/K P/GPa U/kJ/m. K/kJ/m. E(U+K) ', * ' PV H(E+PV) D/g/cm3 V/c3/m ' / 78('-') / * 1X,F6.1,F8.4, F10.3,F8.3,F10.3,F8.3,F10.3, F8.4,F8.3,1X / * 1X,F6.1,F8.4, F10.3,F8.3,F10.3,F8.3,F10.3, F8.4,F8.3,1X / * 78('=') / ' T/K P/GPa A B C ', * ' Alpha Beta Gamma' / 78('-') / * 1X,F6.1,F8.4,1X,3F10.5,3F10.4 / * 1X,F6.1,F8.4,1X,3F10.5,3F10.4 / 78('=') ) RETURN 2000 FORMAT (1X) 2100 FORMAT (132('-')) 2105 FORMAT (132('=')) END C C C ======== C================================================================ PCFRCN SUBROUTINE PCFRCN PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C C -------------------------------------- Pair correlation functions, C Running coordination numbers, C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME COMMON /RADIAL/ NRDF(LTB,LEE),IPRDF(2) INTEGER *4 NRDF COMMON /CONSTS/ PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL REAL *8 PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL C CHARACTER *40 FORM1, FORM2, FORM3, FORM4 REAL *8 PCF(LEF),RHO(LEF),RCN(LEF),PATOM(LEF) INTEGER *4 KRCN(LEF),KPCF(LEF) INTEGER *4 IYEAR,IMONTH,IDAY, IHOUR,IMINUT,ISECND,I100TH C C --------------------------------------- Print pair-RDF's and RCN's C IPRDF(1) : Interval of printing RDF's (0.001*IPRDF(1)) C IPRDF(2) : End of printing RDF's (IPRDF(2)*0.01 Angstroms) C CALL KCLOCK (IYEAR,IMONTH,IDAY,IHOUR,IMINUT,ISECND,I100TH) WRITE (16, 1111) NJOB,TITLE, NRECRD(2), IHOUR,IMINUT,ISECND, * IYEAR,IMONTH,IDAY 1111 FORMAT (//'<<<',I4,'-',I2,' >>> ',15A4,' <<< ',I5, * ' steps >>> at ',I2,':',I2,':',I2, * ' on ',I2,'/',I2,'/',I2 ) C NPAIR = NCOMPO * (NCOMPO+1) / 2 IMULT = 100 IF (NCOMPO.LE.2) THEN IMULT = 1 FORM1 = '(7X, 3(7X,A2,1H-,A2,2X)) ' FORM2 = '(7H R /A , 3(14H pcf rcn ) ) ' FORM3 = '(1X,F5.3,1X, 3(F8.3,F6.3),F6.2) ' FORM4 = '(50(1H-) ) ' ELSE IF (NCOMPO.EQ.3) THEN IMULT = 1 FORM1 = '(7X, 6(6X,A2,1H-,A2,1X)) ' FORM2 = '(7H R /A , 6(12H pcf rcn ) ) ' FORM3 = '(1X,F5.3,1X, 6(F7.2,F5.2),F6.2) ' FORM4 = '(80(1H-) ) ' ELSE IF (NCOMPO.EQ.4) THEN FORM1 = '(7X, 10(5X,A2,1H-,A2)) ' FORM2 = '(7H R /A , 10(10H pcf rcn) ) ' FORM3 = '(1X,F5.3,1X, 10(I6,I4),F6.2) ' FORM4 = '(108(1H-) ) ' ELSE IF (NCOMPO.EQ.5) THEN FORM1 = '(7X, 15(3X,A2,1H-,A2)) ' FORM2 = '(7H R /A , 15(8H pcf rcn) ) ' FORM3 = '(1X,F5.3,1X, 15(I4,I4),F6.2) ' FORM4 = '(127(1H-) ) ' ELSE IF (NCOMPO.GE.6) THEN IMULT = 10 FORM1 = '(6X, 21(1X,A2,1H-,A2)) ' FORM2 = '(6H R /A , 21(6H pc cn) ) ' FORM3 = '(1X,F5.3, 21(I3,I3),F6.2) ' FORM4 = '(133(1H-) ) ' END IF C WRITE (16,2500) IMULT 2500 format (/ 'Pair correlation functions (pcf) and running ', * 'oordination numbers (rcn) of ion pairs ', * '(multiplied by ',I4,')' /) IF (NCOMPO.LE.6) THEN WRITE (16,FORM1) ((ATOM(I),ATOM(J),J=1,I),I=1,NCOMPO) ELSE WRITE (16,FORM1) ((ATOM(I),ATOM(J),J=1,I),I=1,6) END IF WRITE (16,FORM2) WRITE (16,FORM4) L = 0 DO 20 I = 1, NCOMPO DO 10 J = 1, I L = L + 1 AM = 1.0 IF (I.EQ.J) AM = 0.5 EI = REAL(NION(I)) EJ = REAL(NION(J)) RCN(L) = 0.0 PATOM(L) = AMIN1(EI,EJ) * AM RHO(L) = EI * EJ * AM /(BOX(1)*BOX(2)*BOX(3)) 10 CONTINUE 20 CONTINUE IND = 0 I = 10 IEND = IPRDF(2) C 280 R1 = REAL(I)* 0.01 + 0.005*IPRDF(1) R2 = R1 + 0.01*IPRDF(1) VS = 4.0*PI/3.0 * ((R2*R2*R2) - (R1*R1*R1)) PRN = 0 DO 220 L = 1, NPAIR PCF(L) = 0.0 IF (PATOM(L).GT.1.0E-6) THEN PRD = 0.0 DO 210 K = 1, IPRDF(1) PRD = PRD + NRDF(I+K,L) 210 CONTINUE PRN = PRN + PRD PRD = PRD / REAL(NRECRD(2)/irecrd(5)) RCN(L) = RCN(L) + PRD / PATOM(L) PCF(L) = PRD / (VS * RHO(L)) END IF 220 CONTINUE DO 225 L = 1, LEE KRCN(L) = INT(RCN(L) * IMULT + 0.5) KPCF(L) = INT(PCF(L) * IMULT + 0.5) 225 CONTINUE IF (PRN.GT.0.5.AND.IND.EQ.0) THEN IND = 1 IF (IEND.GT.9990) IEND = I + 250 END IF IF (IND.EQ.1) THEN IF (NCOMPO.LE.3) THEN WRITE (16,FORM3) R1+0.01, * (PCF(K),RCN(K),K=1,NPAIR) ELSE IF (NCOMPO.LE.6) THEN WRITE (16,FORM3) R1+0.01, * (KPCF(K),KRCN(K),K=1,NPAIR) ELSE WRITE (16,FORM3) R1+0.01, * (KPCF(K),KRCN(K),K=1,21) END IF END IF I = I + IPRDF(1) IF (I.LT.IEND) GO TO 280 WRITE (16,FORM4) WRITE (16,FORM2) IF (NCOMPO.LE.6) THEN WRITE (16,FORM1) ((ATOM(I),ATOM(J),J=1,I),I=1,NCOMPO) ELSE WRITE (16,FORM1) ((ATOM(I),ATOM(J),J=1,I),I=1,6) END IF C RETURN END C C C ======== C================================================================ POTPLT SUBROUTINE POTPLT PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C C ------------------------------------ Distribution of ion potential C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME COMMON /CONSTS/ PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL REAL *8 PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL C CHARACTER *1 IGRAPH(132) REAL *8 BU(LNI),UMAX(LEM),UMIN(LEM),UAV(LEM) INTEGER *4 NSTAT(132,LEM) C C ------------------------------------------------- Ionic potentials C RNDF = 1.0E12 / REAL(IRECRD(2)) AMAX = -9.9E19 AMIN = 9.9E19 DO 210 IO = 1, NCOMPO UMAX(IO) = 0.0 UMIN(IO) = 0.0 UAV(IO) = 0.0 IF (IION(IO).LE.-999) GO TO 210 IF (NION(IO).GT.0) THEN UMAX(IO) = -9.9E19 UMIN(IO) = 9.9E19 I1 = IONS(1,IO) I2 = IONS(2,IO) DO 100 I = I1, I2 BU(I) = AU(I) * RNDF UAV(IO) = UAV(IO) + BU(I) IF (UMAX(IO).LT.BU(I)) UMAX(IO) = BU(I) IF (UMIN(IO).GT.BU(I)) UMIN(IO) = BU(I) 100 CONTINUE UAV(IO) = UAV(IO) / REAL(NION(IO)) IF (AMAX.LT.UMAX(IO)) AMAX = UMAX(IO) IF (AMIN.GT.UMIN(IO)) AMIN = UMIN(IO) GO TO 160 ELSE UMAX(IO) = 0.0 UMIN(IO) = 0.0 END IF 160 DO 200 J = 1, 132 NSTAT(J,IO) = 0 200 CONTINUE 210 CONTINUE WRITE (16,4004) WRITE (16,4001) WRITE (16,4000) (ATOM(I), UAV(I), UMIN(I),UMAX(I), I=1,6) IF (NCOMPO.GT.6) THEN WRITE (16,4002) (ATOM(I), UAV(I), UMIN(I),UMAX(I), I=7,9) IF (NCOMPO.GT.9) THEN WRITE (16,4003) (ATOM(I), UAV(I), UMIN(I),UMAX(I), I=7,9) END IF END IF C ----------------------------------------------- Plot whole of ions IAMIN = AMIN - 0.999999 IAMAX = AMAX IF (AMAX.GT.0.0) IAMAX = AMAX + 0.999999 UR = 131.0 / (IAMAX - IAMIN) MUP = 0 DO 360 IO = 1, NCOMPO IF (IION(IO).LE.-999) GO TO 360 IF (NION(IO).LE.0) GO TO 360 J1 = IONS(1,IO) J2 = IONS(2,IO) DO 320 J = J1, J2 JU = (BU(J) - IAMIN) * UR + 1.5 NSTAT(JU,IO) = NSTAT(JU,IO) + 1 320 CONTINUE DO 350 J = 1, 132 IF (MUP.LT.NSTAT(J,IO)) MUP = NSTAT(J,IO) 350 CONTINUE 360 CONTINUE IF (MUP.GT.20) MUP = 20 DO 450 N = 1, MUP C WRITE (16,4004) NP = MUP + 1 - N C DO 420 I = 1, NCOMPO DO 405 J = 1, 132 IGRAPH(J) = ' ' 405 CONTINUE IGRAPH(1) = ':' IGRAPH(132) = ':' DO 410 J = 1, 132 DO 400 I = 1, NCOMPO IF (IION(I).GT.-998) THEN IF (NSTAT(J,I).GE.NP) IGRAPH(J) = ATOM(I) END IF 400 CONTINUE 410 CONTINUE WRITE (16, 4010) (IGRAPH(K), K=1,132) 420 CONTINUE 450 CONTINUE WRITE (16, 4020) IAMIN, IAMAX IF (NION(1).LE.1) RETURN C ---------------------------------------- Oxygen ion potential only DO 510 I = 1, 132 NSTAT(I,1) = 0 510 CONTINUE UOMIN = UMIN(1) UOMAX = UMAX(1) IOMIN = UOMIN - 0.999999 IOMAX = UOMAX IF (UOMAX.GT.0.0) IOMAX = UOMAX + 0.999999 UR = 131.0 / (IOMAX - IOMIN) MUP = 0 J1 = IONS(1,1) J2 = IONS(2,1) DO 520 J = J1, J2 JU = (BU(J) - IOMIN) * UR + 1.5 IF (JU.LT.1) JU = 1 NSTAT(JU,1) = NSTAT(JU,1) + 1 520 CONTINUE DO 550 J = 1, 132 IF (MUP.LT.NSTAT(J,1)) MUP = NSTAT(J,1) 550 CONTINUE IF (MUP.GT.20) MUP = 20 DO 650 N = 1, MUP NP = MUP + 1 - N DO 605 J = 1, 132 IGRAPH(J) = ' ' 605 CONTINUE IGRAPH(1) = ':' IGRAPH(132) = ':' DO 610 J = 1, 132 IF (NSTAT(J,1).GE.NP) IGRAPH(J) = ATOM(1) 610 CONTINUE WRITE (16, 4010) (IGRAPH(K), K=1,132) 650 CONTINUE WRITE (16, 4020) IOMIN, IOMAX C 4001 FORMAT ('I',130('-'),'I') 4000 FORMAT ('I Distribution of ion potentials', * 3X,3(4X,A2,F8.3,'[',F7.2,':',F7.2,']'), ' I' * /'I', 17X,'(*1.0E-12 erg)', * 3X,3(4X,A2,F8.3,'[',F7.2,':',F7.2,']'), ' I') 4002 FORMAT ('I',31X, 3X,3(4X,A2,F8.3,'[',F7.2,':',F7.2,']'), ' I') 4003 FORMAT ('I',31X, 3X,1(4X,A2,F8.3,'[',F7.2,':',F7.2,']'), ' I') 4004 FORMAT (1X) 4010 FORMAT (132A1) 4020 FORMAT ('I---<',I5,1X, 110('-'), I5,' >---I' ) RETURN END C C C ======== C================================================================ COORDN SUBROUTINE COORDN PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C C ---------- Comparison between MD derived atomic coordinartes and C crystallographic data C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES(3),PPXYZ(7),FJMOL, * T000,T050, IAXTGR, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME COMMON /ACOORD/ NPT, BOXO(6),NIU(LAA),P0C(3,LAT),NSYM,ISYM(LNI), * NPTP,NBOX(3),JON(LAT),PPC(3,LAT),MATM, * RS(3,3,96),PPS(3,LAT),IHEX COMMON /WORK01/ PCC(3,LNI), PSS(3,LNI) COMMON /WORK02/ P00(3,LNI), XYZ0(3,LNI) C REAL *8 P00(3,LAT), XYZ0(3,LAT) C REAL *8 XYZ(3,LAT),SXYZ(3,LAT) REAL *8 SSS, DDD C INTEGER *4 IPSS(3,LAT) CHARACTER *4 HEX C IND = 0 HEX = ' ' IF (IHEX.EQ.1) HEX = 'HEX' IF (RUNOPT(3).EQ.'DETAIL '.OR.MOD(IRECRD(2),100).EQ.0) * WRITE (16,3003) NJOB, TITLE WRITE (16,3020) NSYM, HEX, (BOX(I)/NBOX(I),NBOX(I),I=1,3) IN1 = 1 RMR = 1.0 / REAL(NRECRD(2)) DO 502 I = 1, NPT C JO = JON(I) JD = INT(P0C(1,I)) +INT(P0C(2,I)) +INT(P0C(3,I)) IF (JD.GE.1.0) IND = 1 DO 500 J = 1, 3 P00(J,I) = P0C(J,I) SSS = PPS(J,I) DDD = PPC(J,I) PSS(J,I) = SQRT(ABS(SSS-DDD**2*RMR)*RMR) PCC(J,I) = PPC(J,I) * RMR 500 CONTINUE 502 CONTINUE C DO 700 KS1 = 1, 2 KS = KS1 - 1 WRITE (16,3030) NT = 0 IUT = 0 DO 590 IU = 1, MATM IF (NIU(IU).LE.0) GO TO 590 NT = NT + NIU(IU) IUT = IUT + 1 DXX = 0.0 DYY = 0.0 DZZ = 0.0 SX = 0.0 SY = 0.0 SZ = 0.0 NO = 0 DO 550 I = IN1, NPT IF (JON(I).GT.NT) GO TO 570 JO = JON(I) JD = INT(P0C(1,I)) +INT(P0C(2,I)) +INT(P0C(3,I)) IF (KS.EQ.0.AND.JD.GE.1) GO TO 550 IF (KS.EQ.1.AND.JD.LT.1) GO TO 550 IN2 = I JS = MOD(ISYM(JO),200) IS = MOD(JS,NSYM) IF (IS.LE.0) IS = NSYM PXO = P00(1,I) PYO = P00(2,I) PZO = P00(3,I) IF (HEX.NE.'HEX '.AND.HEX.NE.'HEXR') GO TO 540 NL = 1 IF (HEX.EQ.'HEXR') NL = 3 IF (JS.GT.NL*NSYM) THEN PYO = PYO - 0.5 IF (PYO.LT.0.0) PYO = PYO + 1.0 PXO = PXO + 0.5 IF (PXO.GE.1.0) PXO = PXO - 1.0 PCC(2,I) = PCC(2,I) - 0.5 DHY = PCC(2,I) - PYO IF (DHY.LT.-.5) PCC(2,I) = PCC(2,I)+1.0 PCC(1,I) = PCC(1,I) + 0.5 DHX = PCC(1,I) - PXO IF (DHX.GE.0.5) PCC(1,I) = PCC(1,I)-1.0 END IF PYO = PYO * 2.0 IF (PYO.GE.1.0) PYO = PYO - 1.0 PXO = PXO + PYO * 0.5 IF (PXO.GE.1.0) PXO = PXO - 1.0 PCC(2,I) = PCC(2,I) * 2.0 DHY = PCC(2,I) - PYO IF (DHY.GE.0.5) PCC(2,I) = PCC(2,I) - 1.0 PCC(1,I) = PCC(1,I) + PCC(2,I) * 0.5 DHX = PCC(1,I) - PXO IF (DHX.GE.0.5) PCC(1,I) = PCC(1,I) - 1.0 DX = PCC(1,I) - PXO DY = PCC(2,I) - PYO DZ = PCC(3,I) - PZO DZZ = DZZ + DZ * RS(3,3,IS) SZ = SZ + ABS(PSS(3,I)) SXI = PSS(1,I) SYI = PSS(2,I) IF (ABS(RS(1,1,IS)*RS(2,1,IS)).GT.0.5) GO TO 10 IF (ABS(RS(1,1,IS)).GE.0.5) THEN DXI = DX * RS(1,1,IS) DYI = (DY - DXI*RS(1,2,IS)) * RS(2,2,IS) GO TO 20 END IF DYI = DX * RS(2,1,IS) DXI = (DY - DYI * RS(2,2,IS)) * RS(1,2,IS) GO TO 20 10 IF (ABS(RS(1,2,IS)).GE.0.5) THEN DXI = DY * RS(1,2,IS) DYI = (DX - DXI * RS(1,1,IS)) * RS(2,1,IS) GO TO 20 END IF DYI = DY * RS(2,2,IS) DXI = (DX - DYI * RS(2,1,IS)) * RS(1,1,IS) 20 DXX = DXX + DXI DYY = DYY + DYI SX = SX + SXI SY = SY + SYI GO TO 545 540 DX = PCC(1,I) - PXO DY = PCC(2,I) - PYO DZ = PCC(3,I) - PZO DXX = DXX + DX*RS(1,1,IS) + DY*RS(2,1,IS) + DZ*RS(3,1,IS) DYY = DYY + DX*RS(1,2,IS) + DY*RS(2,2,IS) + DZ*RS(3,2,IS) DZZ = DZZ + DX*RS(1,3,IS) + DY*RS(2,3,IS) + DZ*RS(3,3,IS) SX= SX+ ABS(PSS(1,I)*RS(1,1,IS)) + ABS(PSS(2,I)*RS(2,1,IS)) * + ABS(PSS(3,I)*RS(3,1,IS)) SY= SY+ ABS(PSS(1,I)*RS(1,2,IS)) + ABS(PSS(2,I)*RS(2,2,IS)) * + ABS(PSS(3,I)*RS(3,2,IS)) SZ= SZ+ ABS(PSS(1,I)*RS(1,3,IS)) + ABS(PSS(2,I)*RS(2,3,IS)) * + ABS(PSS(3,I)*RS(3,3,IS)) 545 NO = NO + 1 IF (JS.NE.1) GO TO 550 XO = PXO YO = PYO ZO = PZO 550 CONTINUE 570 XYZ(1,IU) = XO + DXX / REAL(NO) XYZ(2,IU) = YO + DYY / REAL(NO) XYZ(3,IU) = ZO + DZZ / REAL(NO) SXYZ(1,IU) = SX / REAL(NO) SXYZ(2,IU) = SY / REAL(NO) SXYZ(3,IU) = SZ / REAL(NO) XYZ0(1,IU) = XO XYZ0(2,IU) = YO XYZ0(3,IU) = ZO C WRITE (16,3060) IU,ATMXTL(IU),(XYZ(J,IU),J=1,3), C * (SXYZ(J,IU),J=1,3),(XYZ0(J,IU),J=1,3) IF (RUNOPT(3).NE.'DETAIL '.AND.MOD(IRECRD(2),100).NE.0) * GO TO 580 C DO 575 I = IN1, IN2 C DO 575 J = 1, 3 C IPSS(J,I) = PSS(J,I) * 1000.0 C 575 CONTINUE C WRITE (16,3030) (JON(I), (PCC(J,I),IPSS(J,I),J=1,3), C * I=IN1,IN2) 580 IN1 = IN2 + 1 590 CONTINUE C IU1 = 1 IU2 = 4 601 IF (IU2.GT.IUT) IU2 = IUT WRITE (16,3066) (ATMXTL(IU), * XYZ(1,IU),SXYZ(1,IU),XYZ0(1,IU),IU=IU1,IU2) WRITE (16,3067) (XYZ(2,IU),SXYZ(2,IU),XYZ0(2,IU),IU=IU1,IU2) WRITE (16,3067) (XYZ(3,IU),SXYZ(3,IU),XYZ0(3,IU),IU=IU1,IU2) IU1 = IU2 + 1 IU2 = IU1 + 3 IF (IU1.GT.IUT) GO TO 660 GO TO 601 C 660 IF (IND.EQ.0) RETURN IN1 = NPT / 2 + 1 DO 667 I = IN1, NPT JO = JON(I) JD = INT(P0C(1,I)) + INT(P0C(2,I)) + INT(P0C(3,I)) IF (JD.LT.1) GO TO 667 DO 666 J = 1, 3 ICLJ = 2 IF (NBOX(J).LT.2) ICLJ = 1 P0CJI = P0C(J,I) P00(J,I) = P0CJI - REAL(ICLJ - 1) PCC(J,I) = PPC(J,I) * RMR - REAL(ICLJ - 1) 666 CONTINUE 667 CONTINUE 700 CONTINUE 3003 FORMAT (/'***',I4,'-',I2,' *** ',15A4,' ***') 3020 FORMAT (/'AVERAGE COORDINATES, (STANDARD DEVIATIONS, A^2) AND ', * 'EXPERIMENTAL ONES (NO.SYMM.=',I3,1X,A4,') ', * 3(F8.4,'(X',I2,')') ) 3030 FORMAT (4(2X,I3,F6.3,'(',I2,')',F5.3,'(',I2,')',F5.3,'(',I2,')')) 3060 FORMAT (I3,1X,A4,1X,3F7.4,' (',3F6.4,') ',3F7.4) 3066 FORMAT (4(4X,A4,F7.4,' (',F6.4,') ',F7.4) ) 3067 FORMAT ( 4(8X,F7.4,' (',F6.4,') ',F7.4) ) RETURN END C C C ======== C================================================================ STRCTR SUBROUTINE STRCTR (IPR) PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C C ------------------------------------- Bond lengths and angles etc. C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES(3),PPXYZ(7),FJMOL, * T000,T050, IAXTGR, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /PARAMT/ AIO(LEM),BIO(LEM),CIO(LEM),DIO(LEM),ZIO(LEM), * AIJ(LEF),BIJ(LEF),CIJ(LEF),DIJ(LEF),D4IJ(LEF), * PLIJ(LEF),RSWTCH(LEF),ZIJ(LEF), D7IJ(LEF), * ECORR,VCORR, WIO(LEM), TWEGHT, AKFI(LEM), * ANG3BP(L3P), R3BLIM(2,L3P), * FK3BP(L3P), R3BGRD(2,L3P), R3lim(2,l3p),r3limax, * I3BP(3,L3P), N3BP COMMON /TABLES/ F1(LSR,LEE),E1(LSR,LEE),F0(LTB),E0(LTB) REAL *8 F1,E1,F0,E0 COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME COMMON /VALUES/ TVAL(LVA),TVALL(LVA),VALMAX(LVA),VAL0(LVA), * SVAL(LVA),SVALL(LVA),VALMIN(LVA), * VAL(LVA),AVA(LVA,L50), NAV,NAVT REAL *8 TVAL,SVAL,TVALL,SVALL,VALMAX,VALMIN,VAL0,VAL,AVA COMMON /GEOMET/ DTO(2),AVTHT(12),MBR(8,8,2),NRG(9,2),ITBR(121,12), * RTO(2),SVTHT(12),NBR(8,8,2),MEB(9,2), NTT(121,12), * NTO(2),NVTHT(12),ANGL(3,12),TTAB(LST), NTBL, * ANCN(7,2) common /STRCTU/ lentab COMMON /WORK01/ DONB(6,LNI) COMMON /WORK02/ IONB(6,LNI) COMMON /WORK03/ PX(LNI),PY(LNI),PZ(LNI) C INTEGER *4 NCHAR(7), NCN(7,2), NOCN(5,5) !! REAL *8 ANBR(8,2) CHARACTER *4 CCHAR(8), ATAB(LST) CHARACTER *6 RCHAR(5) DATA RCHAR / 'SIZE ', 'T ', 'T1 ', ' ', ' '/ DATA NCHAR / 0, 1, 2, 3, 4, 5, 6 /, * CCHAR /' 0 ',' 1 ',' 2 ',' 3 ',' 4 ',' 5 ',' 6 ','SUM'/ C IF (RUNOPT(9) .NE.'STRUCTURE ' .AND. * RUNOPT(10).NE.'NETWORK ' ) RETURN MMM = 0 IF (ATOM(2).EQ.ATMNET(1).OR.ATOM(2).EQ.ATMNET(2)) MMM = IONS(2,2) if (ATMNET(2).NE.' ') then IF (ATOM(3).EQ.ATMNET(1).OR.ATOM(3).EQ.ATMNET(2)) MMM = IONS(2,3) end if IF (MMM.EQ.0.AND.IPR.LE.0) RETURN C ----------------------------------------- Default Cut-Off is 2.0 A RTO(1) = 2.00 RTO(2) = 2.00 DO 10 I = 1, 2 IF (ATMNET(I).EQ.'H ') RTO(I) = 1.99 IF (ATMNET(I).EQ.'B ') RTO(I) = 1.90 IF (ATMNET(I).EQ.'C ') RTO(I) = 1.50 IF (ATMNET(I).EQ.'AL') RTO(I) = 2.20 IF (ATMNET(I).EQ.'SI') RTO(I) = 2.00 IF (ATMNET(I).EQ.'P ') RTO(I) = 1.95 IF (ATMNET(I).EQ.'ZR') RTO(I) = 2.30 10 CONTINUE DTO(1) = 0.0 DTO(2) = 0.0 NTO(1) = 0 NTO(2) = 0 DO 410 J = 1, 12 AVTHT(J) = 0.0 SVTHT(J) = 0.0 NVTHT(J) = 0 DO 400 I = 1, 121 NTT(I,J) = 0 400 CONTINUE 410 CONTINUE C DO 440 I = 1, NTION PX(I) = P(1,I) PY(I) = P(2,I) PZ(I) = P(3,I) 440 CONTINUE C C -------------------------------------------------- Cations - anion C DO 220 IO = 1, NCOMPO IF (IION(IO).LE.-999) GO TO 220 IF (NION(IO).LE.0.OR.ZIO(IO).LT.0.0) GO TO 220 C WRITE (*,9001) ATOM(IO) C9001 FORMAT (10X,'*** ',A2,' - ANION ***') IF (IPR.GT.0.AND.RUNOPT(9).EQ.'STRUCTURE ') THEN WRITE (16,2001) ATOM(IO) END IF IT = 0 IF (ATOM(IO).EQ.ATMNET(1)) IT = 1 IF (ATOM(IO).EQ.ATMNET(2)) IT = 2 I1 = IONS(1,IO) I2 = IONS(2,IO) DO 210 I = I1, I2, LENTAB I0 = I CALL DISTAN (I0, II, IO, IPR) IF (IT.EQ.0) GO TO 210 DO 250 IJ = I0, II DO 250 J1 = 1, 5 ID1 = IONB(J1,IJ) D1 = DONB(J1,IJ) IF (D1.GT.RTO(IT).OR.D1.LT.0.1) GO TO 250 D4 = DONB(4,IJ) IF (D4.GT.RTO(IT).OR.D4.LT..1) GO TO 230 IF (J1.GT.4) GO TO 230 DTO(IT) = DTO(IT) + D1 NTO(IT) = NTO(IT) + 1 230 DO 240 J2 = J1+1, 6 ID2 = IONB(J2,IJ) D2 = DONB(J2,IJ) IF (D2.GT.RTO(IT).OR.D2.LT.0.1) GO TO 250 ITT = IT * 3 - 2 IF (ID1.GT.IONS(2,1)) ITT = ITT + 1 IF (ID2.GT.IONS(2,1)) ITT = ITT + 1 CALL ANGLES (ASTHT,IJ,ID1,ID2,D1,D2,ITT) 240 CONTINUE 250 CONTINUE 210 CONTINUE 220 CONTINUE C C +----------------------------------------------------------------I C : Angles 1 : A1-T1-A1 2 : A1-T1-A2 3 : A2-T1-A2 : C : 4 : A1-T2-A1 5 : A1-T2-A2 6 : A2-T2-A2 : C : 7 : T1-A1-T1 8 : T1-A1-T2 9 : T2-A1-T2 : C : 10 : T1-A2-T1 11 : T1-A2-T2 12 : T2-A2-T2 : C +----------------------------------------------------------------I C C ------------- Anion - specified tetrahedron formers, large cations C 300 IT = 0 DO 480 IO = 1, NCOMPO IF (IION(IO).LE.-999) GO TO 480 IF (NION(IO).LE.0.OR.ZIO(IO).GT.0.0) GO TO 480 C WRITE (*,9002) ATOM(IO) C9002 FORMAT (10X,'*** ',A2,' - CATION ***') IT = IT + 1 IF (IPR.GT.0.AND.RUNOPT(9).EQ.'STRUCTURE') THEN WRITE (16, 4001) ATOM(IO) END IF I1 = IONS(1,IO) I2 = IONS(2,IO) DO 430 I = I1, I2, LENTAB I0 = I CALL DISTAN (I0, II, IO, IPR) N = 0 NAG = 0 DO 425 IJ = I0, II N = N + 1 ATAB(N) = ' ' TTAB(N) = 0.0001 ID1 = IONB(1,IJ) ID2 = IONB(2,IJ) IF (ID1.GT.MMM.OR.ID2.GT.MMM) GO TO 425 D1 = DONB(1,IJ) D2 = DONB(2,IJ) IF (D2.GT.RTO(2) .OR. D2.LT.0.01) GO TO 425 IF (D2.GT.RTO(1) .AND. ID1.LE.IONS(2,2)) GO TO 425 ITT = (IT + 2) * 3 - 2 IF (ID1.GT.IONS(2,2)) ITT = ITT + 1 IF (ID2.GT.IONS(2,2)) ITT = ITT + 1 ATAB(N) = '>>>>') 4001 FORMAT (/'<<<<< ', A2, ' - cation distances >>>>>') 4011 FORMAT (4(1X,8A4)) 4012 format (6(1x,5A4)) 4013 format (5(1x,5(a4,1x))) 4014 format (4(1x,5(a4,2x))) 4021 FORMAT (4(1X,8F4.0)) 4022 format (6(1x,5F4.0)) 4023 format (5(1x,5F5.1)) 4024 format (4(1x,5(F5.1,1X))) 5001 FORMAT (/'Vertical: No. of bridging anion to ',A2,' tetrahedra ', * 'Horizontal: No. of bridging anion to ',A2,' tetrahedra', * ' (',i3,')',9X,'<< Tet-Ring >>' * / 111('-'),' << Analysis >>') 5002 format (111('-')) 5003 FORMAT (2(A3,'I', 7F6.2, ' I', F6.2,3X), I3,1X,2F6.2) 5004 format ('No.[CN]',1x,6(i5,'[',i1,']'),3x,6(i5,'[',i1,']')) 5005 FORMAT (A3,'I', I4,6I6,' I ', A3, 4X, * A3,'I', I4,6I6,' I ', A3, 5X, 3A6) 5007 FORMAT (2('---+',43('-'),'+------ '), I3,1X,2F6.2) 5011 format (11x,'Oxygen CN T1 ', !! * 'T2=[0] [1] [2] [3] [4]') !! 5012 format (22x,'[',I1,']',3x,5i7) !! END C C C ======= C================================================================ DISTAN SUBROUTINE DISTAN (I1, I2, IO, IPR) PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C C ----------------------------- Calculation of interatomic distances C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES(3),PPXYZ(7),FJMOL, * T000,T050, IAXTGR, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /PARAMT/ AIO(LEM),BIO(LEM),CIO(LEM),DIO(LEM),ZIO(LEM), * AIJ(LEF),BIJ(LEF),CIJ(LEF),DIJ(LEF),D4IJ(LEF), * PLIJ(LEF),RSWTCH(LEF),ZIJ(LEF), D7IJ(LEF), * ECORR,VCORR, WIO(LEM), TWEGHT, AKFI(LEM), * ANG3BP(L3P), R3BLIM(2,L3P), * FK3BP(L3P), R3BGRD(2,L3P), R3lim(2,l3p),r3limax, * I3BP(3,L3P), N3BP COMMON /TABLES/ F1(LSR,LEE),E1(LSR,LEE),F0(LTB),E0(LTB) REAL *8 F1,E1,F0,E0 COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME common /STRCTU/ lentab COMMON /WORK01/ DONB(6,LNI) COMMON /WORK02/ IONB(6,LNI) COMMON /WORK03/ PX(LNI),PY(LNI),PZ(LNI) C REAL *8 D(64) real *4 dtab(10,lst) INTEGER *4 ID(64),ITAB(10,LST),IDTAB(10,LST),IU(LST) CHARACTER *2 TAX(LST) C ABOXX = BOX(1) ABOXY = BOX(2) ABOXZ = BOX(3) I2 = I1 + LENTAB - 1 IF (I2.GT.IONS(2,IO)) I2 = IONS(2,IO) NI = 0 DO 200 I = I1, I2 NI = NI + 1 NB = 0 PXI = PX(I) PYI = PY(I) PZI = PZ(I) DO 20 J = 1, 64 ID(J) = 0 D(J) = 0.000001 20 CONTINUE DO 90 JO = 1, NCOMPO IF (IION(JO).LE.-999) GO TO 90 IF (NION(JO).LE.0.OR.ZIO(IO)*ZIO(JO).GT.0.0) GO TO 90 DO 100 J = IONS(1,JO), IONS(2,JO) IF (IOND(J).EQ.0 .OR. I.EQ.J) GO TO 100 DX = ABS(PXI-PX(J)) DY = ABS(PYI-PY(J)) DZ = ABS(PZI-PZ(J)) IF (DX.GT.0.5) DX = 1.0 - DX IF (DY.GT.0.5) DY = 1.0 - DY IF (DZ.GT.0.5) DZ = 1.0 - DZ RIJ2 = (DX*ABOXX)**2 +(DY*ABOXY)**2 +(DZ*ABOXZ)**2 IF (RIJ2.LE.9.0.AND.NB.LT.64) THEN NB = NB +1 D(NB) = SQRT(RIJ2) ID(NB) = J END IF 100 CONTINUE 90 CONTINUE IF (NB.GT.1) THEN DO 120 J = 1, NB-1 DO 110 K = J+1, NB IF (D(J).GE.D(K)) THEN DR = D(J) D(J) = D(K) D(K) = DR JD = ID(J) ID(J) = ID(K) ID(K) = JD END IF 110 CONTINUE 120 CONTINUE END IF DO 140 J = 1, 10 ITAB(J,NI) = ID(J) DTAB(J,NI) = D(J) 140 continue do 145 j =1, 6 DONB(J,I) = D(J) IONB(J,I) = ID(J) 145 CONTINUE do 148 j = 1, 10 idtab(j,ni) = dtab(j,ni) * 100.0 + 0.5 148 continue idummy = idtab(1,ni) IU(NI) = AU(I) * 1.E12 / NRECRD(2) + 0.5 200 CONTINUE IF (IPR.EQ.0.OR.RUNOPT(9).NE.'STRUCTURE ') RETURN C WRITE (16,2001) if (lentab.gt.30) then WRITE (16,2011) (I,I=I1,I2) WRITE (16,2021) (IU(I),I=1,NI) end if if (lentab.gt.25.and.lentab.le.30) then WRITE (16,2012) (I,I=I1,I2) WRITE (16,2022) (IU(I),I=1,NI) end if if (lentab.gt.20.and.lentab.LE.25) then WRITE (16,2013) (I,I=I1,I2) WRITE (16,2023) (IU(I),I=1,NI) end if if (lentab.LE.20) then WRITE (16,2014) (I,I=I1,I2) WRITE (16,2024) (IU(I),I=1,NI) end if DO 240 I = 1, 10 ITA = 0 DO 220 J = 1, NI ib = itab(i,j) TAX(J) = '*' IF (IB.GE.ions(1,1).and.ib.LE.ions(2,1)) TAX(J) = ATOM(1) IF (IB.GE.IONS(1,2).and.ib.LE.ions(2,2)) TAX(J) = ATOM(2) IF (IB.GE.IONS(1,3).and.ib.LE.ions(2,3)) TAX(J) = ATOM(3) IF (IB.GE.IONS(1,4).and.ib.LE.ions(2,4)) TAX(J) = ATOM(4) IF (IB.GE.IONS(1,5).and.ib.LE.ions(2,5)) TAX(J) = ATOM(5) IF (IB.GE.IONS(1,6).and.ib.LE.ions(2,6)) TAX(J) = ATOM(6) IF (IB.GE.IONS(1,7).and.ib.LE.ions(2,7)) TAX(J) = ATOM(7) ITA = ITA + ITAB(I,J) 220 CONTINUE IF (ITA.LT.1) GO TO 240 if (lentab.gt.30) then WRITE (16,2031) (IDTAB(I,J),TAX(J),J=1,NI) end if if (lentab.gt.25.and.lentab.le.30) then WRITE (16,2032) (IDTAB(I,J),TAX(J),J=1,NI) end if if (lentab.gt.20.and.lentab.LE.25) then WRITE (16,2033) (IDTAB(I,J),TAX(J),J=1,NI) end if if (lentab.LE.20) then WRITE (16,2034) (IDTAB(I,J),TAX(J),J=1,NI) end if 240 CONTINUE 2001 FORMAT (132('-')) 2011 FORMAT (4(1X,8I4)) 2012 FORMAT (6(1X,5I4)) 2013 FORMAT (5(1X,5(I4,1x))) 2014 FORMAT (4(1X,5(I4,2x))) 2021 FORMAT (4(1X,8I4)) 2022 FORMAT (6(1X,5I4)) 2023 FORMAT (5(1X,5(1x,I4))) 2024 FORMAT (4(1X,5(1x,I4,1x))) 2031 FORMAT (4(1X,8(I3,A1))) 2032 format (6(1x,5(i3,a1))) 2033 format (5(1x,5(i3,a2))) 2034 format (4(1x,5(i3,a2,1x))) RETURN END C C C ======= C================================================================ ANGLES SUBROUTINE ANGLES (THT,IJ,ID1,ID2,D1,D2,IT) PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C C -------------------------------- Calculation of interatomic angles C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES(3),PPXYZ(7),FJMOL, * T000,T050, IAXTGR, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /GEOMET/ DTO(2),AVTHT(12),MBR(8,8,2),NRG(9,2),ITBR(121,12), * RTO(2),SVTHT(12),NBR(8,8,2),MEB(9,2), NTT(121,12), * NTO(2),NVTHT(12),ANGL(3,12),TTAB(LST), NTBL, * ANCN(7,2) COMMON /CONSTS/ PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL REAL *8 PI, ANA, AKB, AHP, EP0, ELC, CVL, CAL COMMON /WORK03/ PX(LNI),PY(LNI),PZ(LNI) C W = 0.0 DO 420 J = 1, 3 DD1 = P(J,ID1)-P(J,IJ) IF (ABS(DD1).GT.0.5) DD1 = DD1-SIGN(1.0,DD1) DD2 = P(J,ID2)-P(J,IJ) IF (ABS(DD2).GT.0.5) DD2 = DD2-SIGN(1.0,DD2) W = W + DD1 * DD2 *BOX(J)**2 420 CONTINUE COSTHT = W / (D1 * D2) SINTHT = ABS(1. - COSTHT*COSTHT) THT = ATAN(SQRT(SINTHT) / COSTHT) * 180.0/PI IF (THT.LT.0.0) THT = THT + 180.0 NVTHT(IT) = NVTHT(IT) + 1 AVTHT(IT) = AVTHT(IT) + THT SVTHT(IT) = SVTHT(IT) + THT * THT ITHT = INT(THT - 58.5) IF (ITHT.LE.0) ITHT = 1 NTT(ITHT,IT) = NTT(ITHT,IT) + 1 RETURN END C C C ======== C================================================================ ADISTR SUBROUTINE ADISTR (IPR) PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C C -------------------------------------- Grafs of interatomic angles C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES(3),PPXYZ(7),FJMOL, * T000,T050, IAXTGR, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /PARAMT/ AIO(LEM),BIO(LEM),CIO(LEM),DIO(LEM),ZIO(LEM), * AIJ(LEF),BIJ(LEF),CIJ(LEF),DIJ(LEF),D4IJ(LEF), * PLIJ(LEF),RSWTCH(LEF),ZIJ(LEF), D7IJ(LEF), * ECORR,VCORR, WIO(LEM), TWEGHT, AKFI(LEM), * ANG3BP(L3P), R3BLIM(2,L3P), * FK3BP(L3P), R3BGRD(2,L3P), R3lim(2,l3p),r3limax, * I3BP(3,L3P), N3BP COMMON /TABLES/ F1(LSR,LEE),E1(LSR,LEE),F0(LTB),E0(LTB) REAL *8 F1,E1,F0,E0 COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME COMMON /GEOMET/ DTO(2),AVTHT(12),MBR(8,8,2),NRG(9,2),ITBR(121,12), * RTO(2),SVTHT(12),NBR(8,8,2),MEB(9,2), NTT(121,12), * NTO(2),NVTHT(12),ANGL(3,12),TTAB(LST), NTBL, * ANCN(7,2) C REAL *8 ANGLE(3,12) INTEGER *4 IANGLE(12) CHARACTER *4 SNGLE(3,12),ATY(LEL),GRAPH(121) C C WRITE (*,1111) C1111 FORMAT (10X,'<<< Angle distribution >>>') N = 0 DO 100 IO = 1, NCOMPO IF (ZIO(IO).LT.0.0) THEN N = N + 1 ATY(N) = ATOM(IO) END IF 100 CONTINUE C IF (IPR.EQ.1) THEN DO 150 I = 1, 12 AVTHT(I) = ANGL(1,I) SVTHT(I) = ANGL(2,I) NVTHT(I) = ANGL(3,I) DO 150 J = 1, 121 NTT(J,I) = ITBR(J,I) 150 CONTINUE END IF C IF (IPR.EQ.0) NTBL = NTBL + 1 MTBL = NTBL IF (MTBL.LE.0) MTBL = 1 IF (NTO(1).GT.0) DTO(1) = DTO(1) / NTO(1) IF (NTO(2).GT.0) DTO(2) = DTO(2) / NTO(2) NTO(1) = NTO(1) / 4 NTO(2) = NTO(2) / 4 IF (IPR.EQ.0) THEN IF (IRECRD(3).GT.0) THEN NN = IRECRD(2)/IRECRD(3) IF (NN.GT.0) MM = MOD(NRECRD(1)/IRECRD(3),NN) END IF MJ = 2 IF (RUNOPT(3).EQ.'ECONOMY ') MJ = 10 IF (MOD(MM,MJ).NE.0) GO TO 270 END IF IF (IPR.EQ.1) THEN WRITE (16, 4005) NTBL, ATMNET(1),ATY(1),DTO(1),NTO(1), * ATMNET(2),ATY(1),DTO(2),NTO(2) 4005 FORMAT(/' Angle distribution (', I3, ')',3X, * A2,'-',A2,'(tet)=', F5.3, ' (', I3, ') ', * A2,'-',A2,'(tet)=', F5.3, ' (', I3, ')') WRITE (16,4011) END IF C 270 NK = 0 ANTBL = REAL(NTBL) DO 490 K = 1, 12 IF (NVTHT(K).EQ.0) GO TO 490 ANN = NVTHT(K) C IF (ANN.LE.0.0) ANN = ANN + 65534 AAA = AVTHT(K) SSS = SQRT(ABS(SVTHT(K) - AAA*AAA/ANN) /ANN) AAA = AAA / ANN NK = NK + 1 ANGLE(1,NK) = AAA ANGLE(2,NK) = SSS IANGLE(NK) = NVTHT(K) IF (K.LE.6) THEN KK = (K - 1)/ 3 + 1 SNGLE(1,NK) = ATY(1) SNGLE(2,NK) = ATMNET(KK) SNGLE(3,NK) = ATY(1) J = MOD(K-1,3) IF (J.GE.1) SNGLE(3,NK) = ATY(2) IF (J.GE.2) SNGLE(1,NK) = ATY(2) GO TO 390 END IF I = 1 IF (MOD(K,3).EQ.0) I = 2 J = 2 IF (MOD(K,3).EQ.1) J = 1 IJ = 1 IF (K.GT.9) IJ = 2 SNGLE(1,NK) = ATMNET(I) SNGLE(2,NK) = ATY(IJ) SNGLE(3,NK) = ATMNET(J) 390 IF (IPR.EQ.1) THEN WRITE (16,4021) (SNGLE(J,NK),J=1,3), AAA, SSS, * NVTHT(K) NMAX = 0 FACT = 400.0 / (ANTBL * NION(1)) DO 450 I = 1, 121 NTT(I,K) = NTT(I,K) * FACT + 0.5 IF (NMAX.LT.NTT(I,K)) NMAX = NTT(I,K) 450 CONTINUE IF (NMAX.GT.17) NMAX = 17 DO 470 I = 1, NMAX NG = NMAX -I + 1 DO 460 J = 1, 121 GRAPH(J) = ' ' IF (J.EQ.1.OR.J.EQ.121) GRAPH(J)='I' MTT = NTT(J,K) IF (MTT.GE.NG) GRAPH(J) = '*' IF (MTT-17.GE.NG) GRAPH(J) = '#' 460 CONTINUE WRITE (16,4010) (GRAPH(J),J=1,121) 4410 FORMAT (80A1) 470 CONTINUE WRITE (16,4011) END IF 490 CONTINUE IF (IPR.EQ.1) THEN WRITE (16,4012) (I, I=60,180,30) RETURN END IF C NN = IRECRD(2)/IRECRD(3) MM = MOD(NRECRD(1)/IRECRD(3), NN) MJ = 2 IF (RUNOPT(3).EQ.'ECONOMY ') MJ = 10 IF (MOD(MM,MJ).EQ.0) THEN WRITE (16,4006) NTBL,ATMNET(1),ATY(1),DTO(1),NTO(1), * ATMNET(2),ATY(1),DTO(2),NTO(2) 4006 FORMAT ('I Angle distribution (', I3, ') ', * A2,'-',A2,'(tet)=', F5.3, ' (', I3, ') ', * A2,'-',A2,'(tet)=', F5.3, ' (', I3, ')I') IF (NK.LE.2) THEN WRITE (16,4020) ( (SNGLE(J,I),J=1,3), * (ANGLE(J,I),J=1,2),IANGLE(I),I=1,NK ) ELSE WRITE (16,4025) ( (SNGLE(J,I),J=1,3), * (ANGLE(J,I),J=1,2),IANGLE(I),I=1,NK ) END IF WRITE (16,4039) 4039 FORMAT ('I',74('-'),'I') END IF DO 710 I = 1, 12 ANGL(1,I) = ANGL(1,I) + AVTHT(I) ANGL(2,I) = ANGL(2,I) + SVTHT(I) ANGL(3,I) = ANGL(3,I) + NVTHT(I) DO 700 J = 1, 121 ITBR(J,I) = ITBR(J,I) + NTT(J,I) 700 CONTINUE 710 CONTINUE RETURN C 4010 FORMAT (3X, 121A1) 4011 FORMAT (3X,12('I',9('-')),'I') 4012 FORMAT (3X,4(I3,27X),I3) 4020 FORMAT ('I ',2(3X,'<',A2,'-',A2,'-',A2,'=',F6.2,'+-',F5.2, * '(N=',I5,')'),' I') 4025 FORMAT ('I ',2(3X,'<',A2,'-',A2,'-',A2,'=',F6.2,'+-',F5.2, * '(N=',I5,')'),' I'/ * 'I ',2(3X,'<',A2,'-',A2,'-',A2,'=',F6.2,'+-',F5.2, * '(N=',I5,')'),' I'/ * 'I ',1(3X,'<',A2,'-',A2,'-',A2,'=',F6.2,'+-',F5.2, * '(N=',I5,')'),36X,' I' ) 4021 FORMAT (3X,'I <',A2,'-',A2,'-',A2,' =',F7.2,'+-',F6.2,' (N=', *I7,')',78X,'I') END C C C ======== C================================================================ NETWRK SUBROUTINE NETWRK (NNN, IPR) PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C C ------------------------------------------------- Network analysis C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES(3),PPXYZ(7),FJMOL, * T000,T050, IAXTGR, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,STEMP,VSTEMP, * TDUMP,PDUMP,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL,DENSTY,VIRM(6), * RCUT(2),NRCUT(2),MXCUT, NFORML,IAXCEN REAL *8 BOX, VBOX, VOL, DENSTY, VIRM, RCUT COMMON /ATOMSI/ P(3,LNI), V(3,LNI), VP(3,LNI), P0(3,LNI), * UI(LNI), AU(LNI), AV3BP(2,L3P), * NTION, NION(LEM), IONS(2,LEM),NCOMPO, Iamv,Namv, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME COMMON /GEOMET/ DTO(2),AVTHT(12),MBR(8,8,2),NRG(9,2),ITBR(121,12), * RTO(2),SVTHT(12),NBR(8,8,2),MEB(9,2), NTT(121,12), * NTO(2),NVTHT(12),ANGL(3,12),TTAB(LST), NTBL, * ANCN(7,2) COMMON /WORK01/ DONB(6,LNI) COMMON /WORK02/ IONB(6,LNI) C INTEGER *4 NTET(19),ITREE(19),MING(9),MEMBER(9),ITET(6,19) integer *4 mring(lrg),ling(9,lrg) C LMBR = 8 LCOL = LMBR * 2 + 1 IF (IPR.EQ.1) GO TO 901 C WRITE (*,1111) C1111 FORMAT (10X,'<<<<< NETWORK ANALYSIS STARTED >>>>>') DO 580 I = 1, 9 MEB(I,1) = 0 MEB(I,2) = 0 580 CONTINUE ISE = 1 IF (NNN.GT.IONS(2,2)) ISE = 2 C --------------------------------------------- Ring search starting write (*,*) 'NETWORK' DO 888 IS = 1, ISE NR = 0 MMM = NNN IF (IS.EQ.1) MMM = IONS(2,2) C DO 705 I = 1, LMBR MEMBER(I) = 0 705 CONTINUE DO 707 I = 1, LCOL DO 707 J = 1, 6 ITET(J,I) = 999999 707 CONTINUE C ------------------------------------- Search around ion [ISI] C ISI : Network former DO 790 ISI = IONS(1,2), MMM c WRITE (6,*) 'ISI=',ISI,' Total Number of Rings =',NR ICOL = 1 ITREE(1) = ISI II = ISI JJ = ISI 710 ICOL = ICOL + 1 IF (ICOL.GT.LCOL) GO TO 725 KJ = 1 IF (JJ.GT.IONS(2,2)) KJ = 2 LL = 0 DO 715 L = 1, 5 ITET(L,ICOL) = 999999 IOS = IONB(L,JJ) IF (IOS.LE.0.OR.IOS.GT.MMM) GO TO 715 IF (IOS.GT.IONS(2,2)) KJ = 2 IF (DONB(L,JJ).GT.RTO(KJ).OR.IOS.EQ.II) GO TO 715 LL = LL + 1 ITET(LL,ICOL) = IOS 715 CONTINUE C NTET(ICOL) = 0 720 NTET(ICOL) = NTET(ICOL) + 1 NTCOL = NTET(ICOL) JJ = ITET(NTCOL,ICOL) IF (JJ.LT.99900) GO TO 730 725 ICOL = ICOL - 1 IF(ICOL.LE.1) GO TO 790 GO TO 720 730 IF (JJ.GT.IONS(2,1).AND.JJ.LT.ISI) GO TO 720 ITREE(ICOL) = JJ II = ITREE(ICOL-1) IF (JJ.NE.ISI) GO TO 710 C -------------------------------------------- Ring detected C Unique for ISI ? DO 740 I = 2, ICOL-2 ITI = ITREE(I) DO 740 J = I+1, ICOL-1 IF (ITI.EQ.ITREE(J)) GO TO 720 740 CONTINUE C ---------------------------- Recorded as a ring temporally MOR = 0 DO 745 I = 1, ICOL-1, 2 MOR = MOR + 1 MING(MOR) = ITREE(I) 745 CONTINUE C -------------------------------------- Sorting in the ring DO 750 I = 1, MOR-1 MIG = MING(I) DO 748 J = I+1, MOR IF (MI.LE.MING(J)) GO TO 748 MM = MIG MIG = MING(J) MING(J) = MM 748 CONTINUE MING(I) = MIG 750 CONTINUE IF (NR.LT.1) GO TO 780 C ------------------------------------- Check for uniqueness IDEL = 0 DO 775 N = 1, NR MM = MRING(N) IF (MM.EQ.0) GO TO 775 IF (MOR.LT.MM) GO TO 760 DO 756 J = 1, MM LI = LING(J,N) DO 755 I = 1, MOR IF (LI.EQ.MING(I)) GO TO 756 755 CONTINUE GO TO 775 756 CONTINUE GO TO 720 C 760 DO 765 I = 1, MOR MI = MING(I) DO 762 J = 1, MM IF (MI.EQ.LING(J,N)) GO TO 765 762 CONTINUE GO TO 775 765 CONTINUE IF (IDEL.GE.1) GO TO 770 MRING(N) = MOR MEMBER(MOR) = MEMBER(MOR) + 1 DO 767 J = 1, MOR LING(J,N) = MING(J) 767 CONTINUE IDEL = 1 GO TO 772 770 MRING(N) = 0 772 MEMBER(MM) = MEMBER(MM) - 1 775 CONTINUE IF (IDEL.GE.1) GO TO 720 780 MEMBER(MOR) = MEMBER(MOR) + 1 NR = NR + 1 IF (NR.GT.LRG) GO TO 791 DO 785 I = 1, MOR LING(I,NR) = MING(I) 785 CONTINUE MRING(NR) = MOR GO TO 720 790 CONTINUE C 791 DO 792 I = 1,LMBR MEB(I,IS) = MEMBER(I) NRG(I,IS) = NRG(I,IS) + MEMBER(I) 792 CONTINUE 888 CONTINUE C WRITE (*,9999) NR 9999 FORMAT (10X,'<<<<< NETWORK: No. of total rings is ',I5,' >>>>>') RETURN C 901 DO 704 IS = 1, 2 DO 702 I = 1, 9 MEB(I,IS) = NRG(I,IS) 702 CONTINUE 704 CONTINUE RETURN END C C C ======== C================================================================ KCLOCK SUBROUTINE KCLOCK (IYEAR,IMONTH,IDAY,IHOUR,IMINUT,ISECND,I100TH) PARAMETER (LNI=62387,LTB=10004, LEL=8, LEM=10, LCT=5000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=19876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*5 ) C COMMON /CHARAC/ TITLE(15),RUNOPT(53),ATOM(LEM),ATMNET(2), * ATMXTL(LAA),FLNAME(19) CHARACTER *4 TITLE,ATOM,ATMNET,ATMXTL CHARACTER *10 RUNOPT CHARACTER *16 FLNAME C INTEGER *4 IYEAR,IMONTH,IDAY, IHOUR,IMINUT,ISECND,I100TH C c write (6,*) flname(3) IF (FLNAME(3).EQ.'NDP-FORTRAN386' .OR. * FLNAME(3).EQ.'DEC Fortran ' .OR. * FLNAME(3).EQ.'NEWS-F77 ') THEN CALL NDP386 (IYEAR,IMONTH,IDAY, * IHOUR,IMINUT,ISECND,I100TH) END IF IF (FLNAME(3).EQ.'Lehey LF90 ' .OR. * FLNAME(3).EQ.'IBM-AIX-FORT ') THEN CALL IBMAIX (IYEAR,IMONTH,IDAY, * IHOUR,IMINUT,ISECND,I100TH) END IF IF (FLNAME(3).EQ.'LUNA88K ') CALL LUNA88 * (IYEAR,IMONTH,IDAY, * IHOUR,IMINUT,ISECND,I100TH) IF (FLNAME(3).EQ.'PARALLEL-F77 ') CALL PARAF7 * (IYEAR,IMONTH,IDAY, * IHOUR,IMINUT,ISECND,I100TH) IF (FLNAME(3).EQ.'ABSOFT F77 ' .OR. * FLNAME(3).EQ.'HP-9000 ') CALL HP9000 * (IYEAR,IMONTH,IDAY, * IHOUR,IMINUT,ISECND,I100TH) IF (FLNAME(3).EQ.'S820-80 ') CALL HTS820 * (IYEAR,IMONTH,IDAY, * IHOUR,IMINUT,ISECND,I100TH) IF (FLNAME(3).EQ.'CRAY-F77 ') CALL CRAY77 * (IYEAR,IMONTH,IDAY, * IHOUR,IMINUT,ISECND,I100TH) IF (FLNAME(3).eq.'Fujitsu F & C ') CALL FUJITSU * (IYEAR,IMONTH,IDAY, * IHOUR,IMINUT,ISECND,I100TH) IF (FLNAME(3).EQ.'IBM-AIX-FORT ') CALL IBMAIX * (IYEAR,IMONTH,IDAY, * IHOUR,IMINUT,ISECND,I100TH) IF (FLNAME(3).EQ.'DEC Fortran ') CALL DECF (IYEAR,IMONTH,IDAY, * IHOUR,IMINUT,ISECND,I100TH) IF (FLNAME(3).EQ.'LINUX - g77 ') CALL g77 (IYEAR,IMONTH,IDAY, * IHOUR,IMINUT,ISECND,I100TH) IF (FLNAME(3).EQ.'Ms-Fortran ') THEN CALL GETDAT (IYEAR,IMONTH,IDAY) CALL GETTIM (IHOUR,IMINUT,ISECND,I100TH) IYEAR = MOD(IYEAR,100) END IF IF (FLNAME(3).EQ.'Dummy ') THEN IYEAR = 0 IMONTH = 0 IDAY = 0 IHOUR = 0 IMINUT = 0 ISECND = 0 I100TH = 0 END IF RETURN END C C C ================= C======================================================= NDP-FORTRAN-386 C and SONY RISC-NEWS SUBROUTINE NDP386 (IYEAR, IMONTH, IDAY, * IHOUR, IMINUT, ISECND, I100TH) C INTEGER *4 IYEAR,IMONTH,IDAY, IHOUR,IMINUT,ISECND,I100TH C c CHARACTER *8 ATIME CHARACTER *9 ADATE CHARACTER *3 BDATE(3), B2 EQUIVALENCE (ADATE,BDATE(1)) c CHARACTER *1 CH c INUM(CH) = ICHAR(CH) - 48 C C CALL TIME (ATIME) C CALL DATE (ADATE) C c IHOUR = INUM(ATIME(1:1))*10 + INUM(ATIME(2:2)) c IMINUT = INUM(ATIME(4:4))*10 + INUM(ATIME(5:5)) c ISECND = INUM(ATIME(7:7))*10 + INUM(ATIME(8:8)) c IYEAR = INUM(ADATE(8:8))*10 + INUM(ADATE(9:9)) c IDAY = INUM(ADATE(1:1))*10 + INUM(ADATE(2:2)) iyear = mod(iyear,100) B2 = BDATE(2) IF (B2.EQ.'JAN' .OR. B2.EQ.'Jan') IMONTH = 1 IF (B2.EQ.'FEB' .OR. B2.EQ.'Feb') IMONTH = 2 IF (B2.EQ.'MAR' .OR. B2.EQ.'Mar') IMONTH = 3 IF (B2.EQ.'APR' .OR. B2.EQ.'Apr') IMONTH = 4 IF (B2.EQ.'MAY' .OR. B2.EQ.'May') IMONTH = 5 IF (B2.EQ.'JUN' .OR. B2.EQ.'Jun') IMONTH = 6 IF (B2.EQ.'JUL' .OR. B2.EQ.'Jul') IMONTH = 7 IF (B2.EQ.'AUG' .OR. B2.EQ.'Aug') IMONTH = 8 IF (B2.EQ.'SEP' .OR. B2.EQ.'Sep') IMONTH = 9 IF (B2.EQ.'OCT' .OR. B2.EQ.'Oct') IMONTH = 10 IF (B2.EQ.'NOV' .OR. B2.EQ.'Nov') IMONTH = 11 IF (B2.EQ.'DEC' .OR. B2.EQ.'Dec') IMONTH = 12 I100TH = 0 RETURN END C C C ========== C============================================================== LUNA-88K SUBROUTINE LUNA88 (IYEAR, IMONTH, IDAY, * IHOUR, IMINUT, ISECND, I100TH) C INTEGER *4 IYEAR,IMONTH,IDAY, IHOUR,IMINUT,ISECND,I100TH C INTEGER *4 JTIME(3),JDATE(3) C do 10 i=1, 3 jtime(i) = 0 jdate(i) = 0 10 continue C C CALL ITIME (JTIME) C CALL IDATE (JDATE) C IYEAR = MOD(JDATE(3),100) IMONTH = JDATE(2) IDAY = JDATE(1) IHOUR = JTIME(1) IMINUT = JTIME(2) ISECND = JTIME(3) I100TH = 0 RETURN END C C C ========== C============================================================== LUNA-88K SUBROUTINE FUJITSU (IYEAR, IMONTH, IDAY, * IHOUR, IMINUT, ISECND, I100TH) C INTEGER *4 IYEAR,IMONTH,IDAY, IHOUR,IMINUT,ISECND,I100TH C INTEGER *4 JTIME(3),JDATE(3) C do 10 i=1, 3 jtime(i) = 0 jdate(i) = 0 10 continue C c CALL ITIME (JTIME) c CALL IDATE (JDATE) C IYEAR = MOD(JDATE(3),100) IMONTH = JDATE(1) IDAY = JDATE(2) IHOUR = JTIME(1) IMINUT = JTIME(2) ISECND = JTIME(3) I100TH = 0 RETURN END C C C ============ C============================================================ Parallel-F SUBROUTINE PARAF7 (IYEAR, IMONTH, IDAY, * IHOUR, IMINUT, ISECND, I100TH) c INTEGER *4 IYEAR,IMONTH,IDAY, IHOUR,IMINUT,ISECND,I100TH C INTEGER *4 JTIME,JDATE,NDAYS(12) DATA NDAYS / 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 / C DATA NDAYS / 31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 / C C 1970.1.1 0:0 - 1992.1.1 0:0 : 365*22+5 daya = 8035 days C 8035*24*60*60 sec = 694224000 sec C GMT > JST : +9 HOURS C CALL ICLOCK (jtime) C jtime = jtime - 694224000 + 32400 JDATE = JTIME / (60*60*24) + 1 C jtime = mod(jtime,24*60*60) IHOUR = jtime/(60*60) jtime = mod(jtime,60*60) IMINUT = JTIME / 60 ISECND = MOD(jtime,60) I100TH = 0 C C NYDAYS = 365 NYDAYS = 366 IYEAR = JDATE / NYDAYS NDAY = JDATE - IYEAR*NYDAYS DO 10 I = 1, 12 IF (NDAY - NDAYS(I).LE.0) GO TO 20 NDAY = NDAY - NDAYS(I) 10 CONTINUE 20 IMONTH = I IDAY = NDAY IYEAR = IYEAR + 92 iyear = mod(iyear,100) RETURN END C C C ================ C======================================================== HP Apollo9000 SUBROUTINE HP9000 (IYEAR, IMONTH, IDAY, * IHOUR, IMINUT, ISECND, I100TH) C INTEGER *4 IYEAR,IMONTH,IDAY, IHOUR,IMINUT,ISECND,I100TH C CHARACTER *8 ATIME C c CALL TIME (ATIME) c CALL IDATE (IMONTH, IDAY, IYEAR) C c write (6,*) atime c write (6,*) imonth, iday, iyear c IHOUR = ICHAR(ATIME(1:1))*10 + ICHAR(ATIME(2:2)) -528 c IMINUT = ICHAR(ATIME(4:4))*10 + ICHAR(ATIME(5:5)) -528 c ISECND = ICHAR(ATIME(7:7))*10 + ICHAR(ATIME(8:8)) -528 c I100TH = 0 iyear = mod(iyear,100) RETURN END C C C ============ C============================================================ H-S-820-80 SUBROUTINE HTS820 (IYEAR, IMONTH, IDAY, * IHOUR, IMINUT, ISECND, I100TH) C INTEGER *4 IYEAR,IMONTH,IDAY, IHOUR,IMINUT,ISECND,I100TH C C CHARACTER *12 ATIME C CHARACTER *8 ADATE C CHARACTER *1 BTIME(8),BDATE(8) C EQUIVALENCE (ATIME,BTIME(1)),(ADATE,BDATE(1)) C C CALL CLOCK (ATIME, 1) C CALL DATE (ADATE) C C IHOUR = (ICHAR(BTIME(1))-240)*10 + (ICHAR(BTIME(2))-240) C IMINUT = (ICHAR(BTIME(4))-240)*10 + (ICHAR(BTIME(5))-240) C ISECND = (ICHAR(BTIME(7))-240)*10 + (ICHAR(BTIME(8))-240) C I100TH = 0 C IYEAR = (ICHAR(BDATE(1))-240)*10 + (ICHAR(BDATE(2))-240) c iyear = mod(iyear,100) C IMONTH = (ICHAR(BDATE(4))-240)*10 + (ICHAR(BDATE(5))-240) C IDAY = (ICHAR(BDATE(7))-240)*10 + (ICHAR(BDATE(8))-240) RETURN END C C C ============ C============================================================ CRAY-C90 SUBROUTINE CRAY77 (IYEAR, IMONTH, IDAY, * IHOUR, IMINUT, ISECND, I100TH) C INTEGER *4 IYEAR,IMONTH,IDAY, IHOUR,IMINUT,ISECND,I100TH C C CHARACTER *8 ATIME C CHARACTER *8 ADATE C CHARACTER *1 CH C INUM(CH) = ICHAR(CH) - 48 C C CALL CLOCK (ATIME) C CALL DATE (ADATE) C IHOUR = INUM(ATIME(1:1))*10 + INUM(ATIME(2:2)) C IMINUT = INUM(ATIME(4:4))*10 + INUM(ATIME(5:5)) C ISECND = INUM(ATIME(7:7))*10 + INUM(ATIME(8:8)) C IYEAR = INUM(ADATE(7:7))*10 + INUM(ADATE(8:8)) C iyear = mod(iyear,100) C IMONTH = INUM(ADATE(1:1))*10 + INUM(ADATE(2:2)) C IDAY = INUM(ADATE(4:4))*10 + INUM(ADATE(5:5)) C I100TH = 0 C RETURN END C C C ================= C======================================================= IBM AIX FORTRAN C and Lehey Fortran 90 SUBROUTINE IBMAIX (IYEAR, IMONTH, IDAY, * IHOUR, IMINUT, ISECND, I100TH) C INTEGER *4 IYEAR,IMONTH,IDAY, IHOUR,IMINUT,ISECND,I100TH C c CHARACTER *1 CH c CHARACTER DAT*8, TIM*10 c character ZONE*5 c INTEGER IVV(8) c INUM(CH) = IACHAR(CH) - 48 C c CALL DATE_AND_TIME (DAT,TIM,ZONE,IVV) C c IHOUR = INUM(TIM(1:1))*10 + INUM(TIM(2:2)) c IMINUT = INUM(TIM(3:3))*10 + INUM(TIM(4:4)) c ISECND = INUM(TIM(5:5))*10 + INUM(TIM(6:6)) c IYEAR = INUM(DAT(3:3))*10 + INUM(DAT(4:4)) c iyear = mod(iyear,100) c IMONTH = INUM(DAT(5:5))*10 + INUM(DAT(6:6)) c IDAY = INUM(DAT(7:7))*10 + INUM(DAT(8:8)) I100TH = 0 RETURN END C C C================================================================= DECF SUBROUTINE DECF (IYEAR, IMONTH, IDAY, * IHOUR, IMINUT, ISECND, I100TH) ! --- Digital Fortran (Unix) & Visual Fortran (Windows) --- ! --- Support Y2000 Problem --- integer*4 IYEAR,IMONTH,IDAY, IHOUR,IMINUT,ISECND,I100TH c character Adtval(3)*12 integer Idtval(8) c c Call DATE_AND_TIME(Adtval(1),Adtval(2),Adtval(3),Idtval) IYEAR = mod(Idtval(1),100) IMONTH = Idtval(2) IDAY = Idtval(3) IHOUR = mod(Idtval(5),100) IMINUT = Idtval(6) ISECND = Idtval(7) I100TH = Idtval(8) RETURN End C C C================================================================= DECF SUBROUTINE G77 (IYEAR, IMONTH, IDAY, * IHOUR, IMINUT, ISECND, I100TH) c --- Linux g77 --- integer*4 IYEAR,IMONTH,IDAY, IHOUR,IMINUT,ISECND,I100TH c integer jtm(9) c integer *4 stime c c stime = Time8() c Call ltime (stime, jtm) isecnd = jtm(1) iminut = jtm(2) ihour = jtm(3) iday = jtm(4) IMONTH = jtm(5)+1 iyear = mod(jtm(6),100) RETURN End