PROGRAM MXDTRICL C=========================================================== C## ## C## Program : MXDTRICL ## C## ## C## by Katsuyuki Kawamura (Hokkaido University) ## C## (Tokyo Institute of Technology) ## C## ## C## Configuration and Energy for Non-Cubic Systems ## C## (Oblique parallelepiped) ## C## with Pressure Control by stress tensor, ## C## and Quantum Correction for energy and pressure ## C## ## C## 2nd order interpolation from U and F tables ## C## ## C## First cubic version on Hitac 8800/8700 80 ## C## First orthogonal (crystal) version 83-10 ## C## on CDC7600 at Manchester Univ. ## C## HITAC M-280/IAP version 85-09-12 ## C## (Px, Py, Pz) pressure control version 87-02-07 ## C## Pressure tensor and ## C## fractional coordinates 87-10-29 ## C## Five element and ## C## input data format and history 87-11-05 ## C## PC9800RA+NDP-FORTRAN-386 version 89-01-26 ## C## Reviced for JCPE 90-04-14 ## C## (XDORTO : DEFECT) 90-04-21 ## C## 3-body interaction (H2O, Kumagai & Kats) 91-02-02 ## C## Integrated version of MD and XD (MXD) 91-05-22 ## C## Rearranged 91-10-23 ## C## Seven comonents, rearranged 92-01-23 ## C## Quatum corrections (Nakao & Kats) 92-03-04 ## C## Ten comonents, rearranged 92-03-31 ## C## Extended Andersen's pressure control 92-04-07 ## C## (Katsuta & Kats) ## C## Metal (main group) potential 92-04-18 ## C## Revised for JCPE version 92-08-01 ## C## 2nd order interpolation from tables 92-09-05 ## C## 2nd order interpolation of velocity 92-12-12 ## C## Nose's thermostat 92-12-14 ## C## Correction for trancation of VW-term 93-12-10 ## C## Reviced 3-body term by Kuma 94-01-30 ## C## L-J potential 94-06-28 ## C## Nose's thermostat + quantum 94-09-01 ## C## Charge - Dipole Interaction 94-09-10 ## C## Improvement of Semi-classical MD 95-06-15 ## C## FILE09.DAT format changed 96-07-18 ## C## Model by Belonoshko & Dubrovinsky 96-09-05 ## C## Shear 97-02-18 ## C## Electric (N.SAWAGUCHI) & Gravity Field 97-06-30 ## C## Apply constant strain rate 97-06-30 ## C## Diatomic 3 chrge model 97-10-10 ## C## 3-body j-i-k with j<>k 99-11-16 ## C## 3-body sqrt(k1xk2) -> k1xk2 00-05-01 ## C## POSISION-VELOCITY-ENERGY option 00-12-16 ## C## Modify EWALD direct term 01-03-24 ## C## 3-body j-i-k : modified 01-09-11 ## c## File07.dat : format 01-12-02 ## C## Polyatomic molecule 02-02-23 ## C## Modify NETWOK analysis (c.n.=5) 02-09-14 ## C## file07.dat (i10) and 3-body 03-Jul-09 ## C## New multi-3-body 03-Jul-28 ## ///// C## Separate file08.dat (file081.dat) 05-Aug-11 ## C=======================================================================I C Format and parameters of 'FILE05.DAT' file : C-----------------------------------------------------------------------I C 1 MD.......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 NOSE :TMPGET :DELTMP :STEMP : : : : 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 SHEAR : SPRES(1):SPRES(2) :SPRES(3) :VIRM(1) :VIRM(2) :VIRM(3): C : SPRES(4):SPRES(5) :SPRES(6) :VIRM(4) :VIRM(5) :VIRM(6): C : Pyz : Pzx : Pxy : : : : 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 8 BUSING :MODE,MXN2:(ALPHA) : : : : : C MORSE : : :(Busing+Morse) : : : C MORSEQ C MORSE-PL : : :(charge-dipole) : : : C MORSE-AT : : : : : : : C BMH-EXP : : 3-body sqrt(k1xk2) : : : C BMH-EXP* : : 3-body k1xk2 : : : C BELONO : : :(Belonoshko & Dubrovinsky) : : C TOSIFUMI : : : : : : : C WOODCOCK : : : : : : : C PAULING : : :(Woodcock+Pauling f.) : : C METAL : : : : : : : C STSUNE : : :(Tsuneyuki et al.) : : : 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 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 82e[BLANK] : : : : : : : C : : : : : : : C 91 STRUCTURE: : : 9 :[Detail of final structure]: C 92 NETWORK :NFCION(1):NFCION(2): 10 :[Network structure analys.]: 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 : [Table of PCF and RCN]: C*96 DIPOLE : : : 14 : [E(dipole moment)]: C 97 CENTER : : : 15 : [Centring of atom cluster]: C 98 NO(MV=0) : : : 16 :[No correction for morment]: 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 : DINTRA :iatom2(1):iatom2(2): 23:[Diatomic molec]: C 9I MOLECULE : Dintra : Mstart : Mend : 26:[Define molecule] C 9L POLYATOM : Dintra :MOLstart : MOLend : 29:[Polyatomic molecule]: C 9n ........ : : : : : : : C 9e [BLANK] : : : : : : : C : : : : : : : 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 Variables in PARAMERER statement : 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,4X, 74X, ' I') 2223 FORMAT ('I ',I7,I5,I3,I7,4X, I7,I5,I3,I7,4X, I7,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=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST(3,3),SPRES(6),PPXYZ(7), * FJMOL, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY COMMON /CARTES/ H(3,3),HINV(3,3),RBOX(6), * G(3,3),GINV(3,3),TRANSX(8),TRANSY(8),TRANSZ(8) * ,Q(3,LNI),Q0(3,LNI) REAL *8 H,HINV,G,GINV,RBOX,Q,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, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /VALUES/ VAL(LVA), TVAL(LVA),TVALL(LVA),VALMAX(LVA), * VAL0(LVA),SVAL(LVA),SVALL(LVA),VALMIN(LVA), * AVA(LVA,L50), NAV,NAVT REAL *8 VAL,TVAL,TVALL,VALMAX,VAL0,SVAL,SVALL,VALMIN 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 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 CHARACTER *10 RUNO18,RUNO19 CHARACTER *4 TITLE0(15), BIN CHARACTER *1 DEFECT 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(I),I=1,3), * 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 (5X,14('='),' Titles in FILE07.DAT and FILE05.DAT are ', * 14('=') / '=====[F7]: ',15A4,' ===== ' / * '=====[F5]: ',15A4,' ===== ' ) 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 write (6,*) i,defect 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.' go to 201 c 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 = 'H-TENSOR ' 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(I),I=1,3), * DTIME, RUNO18, BOX, * DENSTY, RUNO19, VBOX IF (RUNO18.EQ.'THERMOSTAT') WRITE (17,7080) STEMP,VSTEMP DO 503 I = 1, 3 WRITE (17,7080) (H(I,J),J=1,3) 503 CONTINUE 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 ',13('='), * ' End=',I6,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=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /VALUES/ VAL(LVA), TVAL(LVA),TVALL(LVA),VALMAX(LVA), * VAL0(LVA),SVAL(LVA),SVALL(LVA),VALMIN(LVA), * AVA(LVA,L50), NAV,NAVT REAL *8 VAL,TVAL,TVALL,VALMAX,VAL0,SVAL,SVALL,VALMIN 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 /CARTES/ H(3,3),HINV(3,3),RBOX(6), * G(3,3),GINV(3,3),TRANSX(8),TRANSY(8),TRANSZ(8) * ,Q(3,LNI),Q0(3,LNI) REAL *8 H,HINV,G,GINV,RBOX,Q,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 /WORK02/ IP(3,LNI), PP(3,LNI) C REAL *8 HH(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.5 / * 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, HH READ (19) ((PP(J,I),J=1,3),I=1,MMMMM) WRITE (22) L, HH 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, HH READ (22) ((PP(J,I),J=1,3),I=1,MMMMM) WRITE (19) L, HH WRITE (19) ((PP(J,I),J=1,3),I=1,MMMMM) 450 CONTINUE ELSE DO 460 K = 1, NRECRD(4) READ (19,9002) L, HH READ (19,9001) ((IP(J,I),J=1,3),I=1,MMMMM) WRITE (22,9002) L, HH 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, HH READ (22,9001) ((IP(J,I),J=1,3),I=1,MMMMM) WRITE (19,9002) L, HH 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 (I5,5X, 9F7.3) END C C C ======== C================================================================ FILE10 SUBROUTINE FILE10 PARAMETER (LNI=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) C COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY 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, * 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=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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,TDUMP,PDUMP, * STEMP,VSTEMP,PREST(3,3),SPRES(6),PPXYZ(7), * FJMOL, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY 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, * 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),RBOX(6), * G(3,3),GINV(3,3),TRANSX(8),TRANSY(8),TRANSZ(8) * ,Q(3,LNI),Q0(3,LNI) REAL *8 H,HINV,G,GINV,RBOX,Q,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 COMMON /VECTOR/ FNV(LNV), UNV(LNV), PNV(3,3,LNV), * VEC(3,LNV), ZIA(LEM), ALPHA, UCSELF,UCSLFI(LEM), * MODE, NVN, NVEC(3,LNV) REAL *8 FNV,UNV,PNV,VEC,ZIA,ALPHA,UCSELF COMMON /VALUES/ VAL(LVA), TVAL(LVA),TVALL(LVA),VALMAX(LVA), * VAL0(LVA),SVAL(LVA),SVALL(LVA),VALMIN(LVA), * AVA(LVA,L50), NAV,NAVT REAL *8 VAL,TVAL,TVALL,VALMAX,VAL0,SVAL,SVALL,VALMIN 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 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), STRT(3), MEFD REAL *8 EFD, EFREQ, GFD, STRT COMMON /MOLECU/ ZMOLE(2), DMOLE(4,LNI), DINTRA, * NDMOLE, IDMOLE(3,LNI), IATOM2(2), MOLstart(2), * NMOLE, IMOLE(38,LNI), MMOLE(LNI), MOLend(2) real *8 zmole,dmole COMMON /WORK01/ VV(3,LNI), DUM(3,LNI) COMMON /WORK02/ IPV(3,LNI),IDUMMY(3,LNI) C REAL *8 BOXA(6), FA(3), param1,param2,param3,param4,param5 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 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.') THEN RUNOPT(1) = 'MD.......:' RUNOP1 = 'MD..' IP0 = 1 END IF IF (RUNOP1.EQ.'MD..') THEN RUNOPT(1) = 'MD........' RUNOPT(17) = 'AMORPHOUS ' END IF IF (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.'END ' ) GO TO 888 IF (RUNOPT(2).EQ.'CONT. ') * 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,0) C ------------------------------------------- Economy, normal detail READ (15,1000) RUNOPT(3), AREC1, AREC2, AREC3, AREC4, AREC5 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 ------------------------------------------------------ Temperatute 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 SCALING ') THEN RUNOPT(5) = 'T SCALING ' NTSTEP = STEMP0 END IF IF (RUNRUN.EQ.'T NOSE ') RUNOPT(5) = 'T NOSE ' C -------------------------------------- IF (RUNOPT(5) .NE.'T NOSE ' .OR. * RUNOPT(2) .NE.'CONTINUE ' .OR. * RUNOPT(51).NE.'THERMOSTAT' ) THEN STEMP = STEMP0 VSTEMP = 0.0 END IF IF (NTSTEP.LE.0) NTSTEP = 1 DELTMP = DELT TMPGET = TARGT IF (TDUMP.LT.0.001) TDUMP = 0.5 C --------------------------------------------------------- Pressure READ (15,1000) RUNRUN, (SPRES(I),I=1,3), VIRM(1),VIRM(2),VIRM(3) pdump = 1.0 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 ') THEN RUNOPT(6) = 'P SCALING ' SPRES(4) = 0.0 SPRES(5) = 0.0 SPRES(6) = 0.0 pdump = virm(1) if (pdump.lt.0.01) pdump = 1.0 end if IF (RUNRUN.EQ.'P ANDERSEN') THEN RUNOPT(6) = 'P ANDERSEN' 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 IF (RUNRUN.EQ.'P SHEAR ') THEN RUNOPT(6) = 'P SHEAR ' READ (15,1000) DUMMY, (SPRES(I),I=4,6), * (VIRM(I),I=4,6) END IF C ----------------------------------------------------------- Volume READ (15,1000) RUNRUN, BOXA IF (RUNRUN.EQ.' ') RUNOPT(7) = 'V FREE ' IF (RUNRUN.EQ.'V CONST. ') 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 ') THEN RUNOPT(7) = 'V CELL ' DO 400 J = 1, 3 FA(J) = BOXA(J) / BOX(J) BOX(J) = BOXA(J) 400 CONTINUE BOX(4) = BOXA(4) BOX(5) = BOXA(5) BOX(6) = BOXA(6) C ----------------------------------------- Change density ELSE IF (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 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-PL ' .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.'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) IF (I.NE.1) ZSUM = ZSUM + ZJ * ANJ IF (ATY.EQ.'-') IION(I) = -1 IF (ATY.EQ.'*') IION(I) = -999 IF (ATY.EQ.'=') IION(I) = 1 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 write (6,*) 'Number of components is ',NCOMPO 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 (RUNOPT(17).EQ.'AMORPHOUS '.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 C IF (RUNOPT(6).EQ.'P SCALING ') THEN WRITE (16,2020) RUNOPT(6),(SPRES(I),I=1,3) ELSE IF (RUNOPT(6).EQ.'P ANDERSEN') THEN WRITE (16,2027) RUNOPT(6), (SPRES(I),I=1,3), * (VIRM(LL),LL=1,3) ELSE IF (RUNOPT(6).EQ.'P SHEAR ') THEN WRITE (16,2028) RUNOPT(6), (SPRES(I),I=1,3), * (SPRES(I),I=4,6) ELSE WRITE (16,2022) RUNOPT(6) END IF C CALL TABLER (1) C C ------------------------------------------ Read RUNOPT(9),...,(22) lentab = lst IPRDF(1) = 2 IPRDF(2) = 9999 520 READ (15,1000) RUNRUN,PARAM1,PARAM2,PARAM3,PARAM4,PARAM5,PARAM6 IF (RUNRUN.NE.' ') THEN IF (RUNRUN.EQ.'STRUCTURE ') then ! STRUCTURE [9] RUNOPT(9) = 'STRUCTURE ' lentab = param1 if (lentab.lt.1) lentab = lst if (lentab.gt.LST) lentab = lst end if IF (RUNRUN.EQ.'NETWORK ') THEN ! NETWORK [10] 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 (6,*) 'Network forming cation(s) is(are)', * (i,atmnet(i),i=1,natx) END IF C IF (RUNRUN.EQ.'VELOCITY ') THEN ! VELOCITY [11] RUNOPT(11) = 'VELOCITY ' IRECRD(9) = PARAM1 PVMULT = 50000.0 IF (PARAM2.GT.0.0) PVMULT = PARAM2 IF (IRECRD(9).LE.0) IRECRD(9) = 1 END IF IF (RUNRUN.EQ.'POSITION ') THEN ! POSITION [11] RUNOPT(11) = 'POSITION ' IRECRD(9) = PARAM1 PVMULT = 9000.0 IF (PARAM2.GT.0.0) PVMULT = PARAM2 IF (IRECRD(9).LE.1) IRECRD(9) = 1 END IF IF (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 ') 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 ') THEN ! QUANTUM [12] RUNOPT(12) = 'QUANTUM ' CALL QCTABL END IF IF (RUNRUN.EQ.'PCF '.OR. ! PCF or RDF.[13] * 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 ') THEN ! DIPOLE [14] RUNOPT(14) = 'DIPOLE ' END IF IF (RUNRUN.EQ.'CENTER ') THEN ! CENTER [15] RUNOPT(15) = 'CENTER ' END IF IF (RUNRUN.EQ.'NO(MV=0) ') THEN ! NO(MV=0) [16] RUNOPT(16) = 'NO(MV=0) ' END IF IF (RUNRUN.EQ.'CRYSTAL ') THEN ! CRYSTAL [17] RUNOPT(17) = 'CRYSTAL ' END IF IF (RUNRUN.EQ.'BINARY ') THEN ! BINARY [18] 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 ! PRESSURE [19] RUNOPT(19) = 'PRESSURE ' OPEN (27, FILE=FLNAME(13), STATUS='UNKNOWN', * ACCESS='SEQUENTIAL', FORM='FORMATTED' ) REWIND 27 END IF IF (RUNRUN.EQ.'ELEC.FIELD') THEN ! ELEC.FIELD [20] 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 ! GRAV.FIELD [21] runopt(21) = 'GRAV.FIELD' gfd(1) = param1 gfd(2) = param2 gfd(3) = param3 end if if (runrun.eq.'CONSTSHEAR') then ! CONSTSHEAR [22] runopt(22) = 'CONSTSHEAR' C ----- Shear rate / ps ( dvx/dry ) C ( dvy/drz ) C ( dvx/drz ) STRT(1) = param1 STRT(2) = param2 STRT(3) = param3 IF (RUNOPT(6).EQ.'P SCALING '.OR. * RUNOPT(6).EQ.'P ANDERSEN'.OR. * RUNOPT(6).EQ.'P SHEAR ' )then write (6,*) 'Error ',runopt(6),runopt(22) stop end if end if if (runrun.eq.'DIATOMIC ') then ! DIATOMIC [23] runopt(23) = 'DIATOMIC ' DINTRA = param1 IATOM2(1) = param2 IATOM2(2) = param3 MOLstart(1) = param2 MOLend(1) = param2 MOLstart(2) = param3 MOLend(2) = param3 ZMOLE(1) = - ZIO(IATOM2(1))*2.0 if (iatom2(2).gt.0) zmole(2) = - ZIO(IATOM2(2))*2.0 CALL DIATOM end if if (runrun.eq.'MOLECULE ') then runopt(26) = 'MOLECULE ' DINTRA = param1 MOLstart(1) = param2 MOLend(1) = param3 call MOLECULE end if if (runrun.eq.'POLYATOMS ') then runopt(29) = 'POLYATOMS ' DINTRA = param1 MOLstart(1) = param2 MOLend(1) = param3 call MOLECULE end if GOTO 520 END IF WRITE (16,2030) (I,RUNOPT(I),I=1,24) C ---------------------------------------------------- Check P and V CALL CHECKP (DTMO) C ------------------------------------------------------ file09p.dat IF (RUNOPT(2).EQ.'START ') THEN IF (TITLE(1).NE.'BENC' .OR. * TITLE(2).NE. 'HMAR' ) THEN IF (RUNOPT(17).EQ.'AMORPHOUS ') THEN NRECRD(4) = 1 IF (RUNOPT(18).EQ.'BINARY ') THEN WRITE (19) NRECRD(4), 0, ((H(J,I),J=1,3),I=1,3) WRITE (19) ((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,9002) NRECRD(4), 0, * ((H(J,I),J=1,3),I=1,3) WRITE (19,9001) ((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,9002) NRECRD(1),IRECRD(9) WRITE (28,9001) ((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), H WRITE (28) ((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,9002) NRECRD(1),IRECRD(9), H WRITE (28,9001) ((IPV(J,I),J=1,3),I=1,NTION) END IF END IF 9001 FORMAT (18I4) 9002 FORMAT (I7,i3, 9F7.3) 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' ) 2022 FORMAT ('I [ ',A10,' ] MD basic cell is fixed at the present ', * 'size and shape. ', 57X, 'I') 2020 FORMAT ('I [ ',A10,' ] Pressure is controlled at Px=',F8.4, * ' Py=',F8.4, * ' Pz=',F8.4, * ' GPa using forced scaling of cell ', * 'dimensions.',5X,'I') 2027 FORMAT ('I [ ',A10,' ] Pressure is controlled at ',3F9.4, * ' GPa by Andersen''s mass ',3(1X,G9.2E3), * ' g I') 2028 FORMAT ('I [ ',A10,' ] Pressure is controlled at Px=',F9.4, * ' Py=',F9.4, * ' Pz=',F9.4, * ' GPa using forced scaling of cell ', * 'dimensions.',2X,'I'/ * 'I ',10X,30X, 'Pyz=',F8.4,' Pzx=',F8.4,' Pxy=',F8.4, * ' GPa',44X, 'I' ) 2030 format ('I',130('-'),'I' / * 'I [Options] ',8(I3,':',A10),' I' / * 'I ',8(I3,':',A10),' I' / * 'I ',8(I3,':',A10),' I' ) END C C C ========== C============================================================== MOLECULE SUBROUTINE MOLECULE PARAMETER (LNI=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) C ======================================recognize diatomic molecules COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY 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, * 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),RBOX(6), * G(3,3),GINV(3,3),TRANSX(8),TRANSY(8),TRANSZ(8) * ,Q(3,LNI),Q0(3,LNI) REAL *8 H,HINV,G,GINV,RBOX,Q,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, * NDMOLE, IDMOLE(3,LNI), IATOM2(2), MOLstart(2), * NMOLE, IMOLE(38,LNI), MMOLE(LNI), MOLend(2) real *8 zmole,dmole c real *8 pix,piy,piz, pjx,pjy,pjz, rx,ry,rz, dx,dy,dz, * pjx0,pjy0,pjz0, rij2 integer mi(lni), ndistr(38) c cut2 = dintra**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 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) DX = H(1,1)*RX + H(1,2)*RY + H(1,3)*RZ DY = H(2,1)*RX + H(2,2)*RY + H(2,3)*RZ DZ = H(3,1)*RX + H(3,2)*RY + H(3,3)*RZ c DX = RX * BOX(1) c DY = RY * BOX(2) c 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 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) DX = H(1,1)*RX + H(1,2)*RY + H(1,3)*RZ DY = H(2,1)*RX + H(2,2)*RY + H(2,3)*RZ DZ = H(3,1)*RX + H(3,2)*RY + H(3,3)*RZ c DX = RX * BOX(1) c DY = RY * BOX(2) c 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) write (6,1002) (n,n=1,38), (ndistr(n),n=1,38) 1002 format ('N.A',19I4 / 3X,19I4 / 'N.M',19I4 / 3x,19I4) RETURN END C C C ======== C================================================================ DIATOM SUBROUTINE DIATOM PARAMETER (LNI=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) C ======================================recognize diatomic molecules COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY 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, * 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),RBOX(6), * G(3,3),GINV(3,3),TRANSX(8),TRANSY(8),TRANSZ(8) * ,Q(3,LNI),Q0(3,LNI) REAL *8 H,HINV,G,GINV,RBOX,Q,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, * 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**2 nnn = 0 do 900 iii = 1, 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) DX = H(1,1)*RX + H(1,2)*RY + H(1,3)*RZ DY = H(2,1)*RX + H(2,2)*RY + H(2,3)*RZ DZ = H(3,1)*RX + H(3,2)*RY + H(3,3)*RZ c DX = RX * BOX(1) c DY = RY * BOX(2) c 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=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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,TDUMP,PDUMP, * STEMP,VSTEMP,PREST(3,3),SPRES(6),PPXYZ(7), * FJMOL, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY 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, * 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/ VAL(LVA), TVAL(LVA),TVALL(LVA),VALMAX(LVA), * VAL0(LVA),SVAL(LVA),SVALL(LVA),VALMIN(LVA), * AVA(LVA,L50), NAV,NAVT REAL *8 VAL,TVAL,TVALL,VALMAX,VAL0,SVAL,SVALL,VALMIN 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 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, LEL 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=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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,TDUMP,PDUMP, * STEMP,VSTEMP,PREST(3,3),SPRES(6),PPXYZ(7), * FJMOL, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY 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, * 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 DL,FV,TT,RL,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.0D0) 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=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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,TDUMP,PDUMP, * STEMP,VSTEMP,PREST(3,3),SPRES(6),PPXYZ(7), * FJMOL, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY 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, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /VECTOR/ FNV(LNV), UNV(LNV), PNV(3,3,LNV), * VEC(3,LNV), ZIA(LEM), ALPHA, UCSELF,UCSLFI(LEM), * MODE, NVN, NVEC(3,LNV) REAL *8 FNV,UNV,PNV,VEC,ZIA,ALPHA,UCSELF 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 / *' ******* ************************** ', *' **** *********** ******** ', *' ***** ********* ******** ', *' ****** ********** ********* ', *' ******* *********** *********', *' **** *** ************ *********', *' *** *** *** ********* *********', *' *** *** *** ********* Oblique *********', *' *** *** *** ********* *********', *' *** *** *** ********* ******** ', *' *** ******* ********* ******* ', *' **** ***** ********* ******* ', *' ***** *** ********* ******* ', *' ***** * ********* ******* ', *' ******* ********* ****** ', *' ******** *********** ****** ', *'*********** ************************ R', *' '/ DATA LOGO2 / *'************ ************************* ', *' ********* ************ ******* ', *' ******** *********** ******* ', *' ******* *** ******** ******** ', *' ****** *** ******** ******** ', *' ****** *** ******** ********', *' ****** *** ******** ********', *' ******** ******** Oblique ********', *' ****** ******** ********', *' ******** ******** ******* ', *' *** ****** ******** ******* ', *' *** ****** ******** ******* ', *' *** ****** ******** ******* ', *' *** ****** ******** ****** ', *' **** ****** ******** ****** ', *' ****** ******* ********** ****** ', *'********** *************************** 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 IDX = 0 IF (RUNOPT(52).EQ.'H-TENSOR ') IDX =1 CALL TMATRX (IDX) 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, VOL, LOGO1(4), LOGO1(5) WRITE (16,5002) MODE,NVN, RCUT(2), LOGO1(6), * RUNOPT(8),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 Cell.Vol :', * F12.5, 3X,'I ',A63, ' I' / * 'I--',60('-'),'I ',A63, ' I' ) 5002 FORMAT('I P-model : Mode=',I3,' (N(Nv)=',I4,') ', * 'Rcut(S)=',F7.3,' A I ',A63,' I' / * 'I ',A8,' : Alpha(EWALD)=',F6.3,' A-1 ', * 'Rcut(L)=',F7.3,' A 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 ',A52,A11,' 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.'MORSEQ ') CALL MORSEQ IF (RUNOPT(8).EQ.'MORSE-PL ') CALL MORSEP IF (RUNOPT(8).EQ.'MORSE-AT ') CALL MORSEP 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 C IF (RUNOPT(3).EQ.'DETAIL ') THEN DO 200 I = 70, 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 = 70, 300, 10 RIJ = I * 0.01 WRITE (16,6666) RIJ,F0(I),(F1(I,J),J=1,NPAIR) 210 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-PL ' .OR. RUNOPT(8).EQ.'MORSE-AT ' .OR. * RUNOPT(8).EQ.'BMH-EXP ' .OR. RUNOPT(8).EQ.'BELONO ' .OR. * RUNOPT(8).EQ.'BMH-EXP* ' .OR. runopt(8).eq.'MORSEQ ' .or. * runopt(8).eq.'BMH-EXPQ ' .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 (IDX) PARAMETER (LNI=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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, * 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 /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, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY COMMON /CARTES/ H(3,3),HINV(3,3),RBOX(6), * G(3,3),GINV(3,3),TRANSX(8),TRANSY(8),TRANSZ(8) * ,Q(3,LNI),Q0(3,LNI) REAL *8 H,HINV,G,GINV,RBOX,Q,TRANSX,TRANSY,TRANSZ C REAL *8 SINA(3), COSA(3), DET, GG, BOXIJ C 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 10 I = 0, 1 DO 10 J = 0, 1 DO 10 K = 0, 1 N = N + 1 TRANSX(N) = DBLE(I) TRANSY(N) = DBLE(J) TRANSZ(N) = DBLE(K) 10 CONTINUE C IF (IDX.NE.0) THEN DO 50 I = 1, 3 BOX(I) = SQRT(H(1,I)**2 + H(2,I)**2 + H(3,I)**2) 50 CONTINUE DO 68 I = 1, 3 K1 = 2 K2 = 3 IF (I.EQ.2) THEN K1 = 1 K2 = 3 ELSE IF (I.EQ.3) THEN K1 = 1 K2 = 2 END IF BOXIJ= H(1,K1)*H(1,K2)+H(2,K1)*H(2,K2)+H(3,K1)*H(3,K2) COSA(I) = BOXIJ / (BOX(K1)*BOX(K2)) BOX(I+3) = COSA(I) SINA(I) = SQRT(1.0D0 - COSA(I)**2) 68 CONTINUE GO TO 150 END IF C C ---------------------------- cos and sin of alpha, beta, and gamma DO 120 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) 120 CONTINUE C C ------------------ Transformation matrix from crystal to Cartesian C H(1,3) = 0.0D0 H(2,3) = 0.0D0 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) cc H(2,1) = BOX(1)*COSA(3)*SINA(1) cc H(1,1) = BOX(1)*SQRT(1.0D0-COSA(2)**2-(COSA(3)*SINA(1))**2) H(2,1) = -BOX(1)*(COSA(1)*COSA(2)-COSA(3))/SINA(1) H(1,1) = BOX(1)*SQRT(1-COSA(1)**2-COSA(2)**2-COSA(3)**2+ * 2*COSA(1)*COSA(2)*COSA(3))/SINA(1) 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 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 150 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 VOL = DET DENSTY = TWEGHT / (ANA * VOL * 1.0D-24) C C ---------------------------------------------------- Metric tensor DO 180 I = 1, 3 DO 180 J = 1, 3 GG = 0.0 D0 DO 170 K = 1, 3 GG = GG + H(K,J) * H(K,I) 170 CONTINUE G(J,I) = GG 180 CONTINUE CALL INVERS (G, DET, GINV) 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) RETURN END C C C ======== C================================================================ INVERS SUBROUTINE INVERS (X, DET, XINV) C -------------------------------------------- Given 3 by 3 matrix X C Store determinant at D 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 SUBROUTINE PTOXYZ (I) PARAMETER (LNI=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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, * 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),RBOX(6), * G(3,3),GINV(3,3),TRANSX(8),TRANSY(8),TRANSZ(8) * ,Q(3,LNI),Q0(3,LNI) REAL *8 H,HINV,G,GINV,RBOX,Q,TRANSX,TRANSY,TRANSZ C REAL *8 PX,PY,PZ C C -------------------------------- TRANSFORMATION OF ION COORDINATES C FROM CRYSTAL TO CARTESIAN (X,Y,Z) C PX = P(1,I) PY = P(2,I) PZ = P(3,I) Q(1,I) = H(1,1)*PX + H(1,2)*PY + H(1,3)*PZ Q(2,I) = H(2,1)*PX + H(2,2)*PY + H(2,3)*PZ Q(3,I) = H(3,1)*PX + H(3,2)*PY + H(3,3)*PZ C PX = P0(1,I) PY = P0(2,I) PZ = P0(3,I) Q0(1,I) = H(1,1)*PX + H(1,2)*PY + H(1,3)*PZ Q0(2,I) = H(2,1)*PX + H(2,2)*PY + H(2,3)*PZ Q0(3,I) = H(3,1)*PX + H(3,2)*PY + H(3,3)*PZ RETURN END C C C ======== C================================================================ XYZTOP C SUBROUTINE XYZTOP PARAMETER (LNI=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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, * 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),RBOX(6), * G(3,3),GINV(3,3),TRANSX(8),TRANSY(8),TRANSZ(8) * ,Q(3,LNI),Q0(3,LNI) REAL *8 H,HINV,G,GINV,RBOX,Q,TRANSX,TRANSY,TRANSZ C 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 QX = Q(1,I) QY = Q(2,I) QZ = Q(3,I) P(1,I) = HINV(1,1)*QX + HINV(1,2)*QY + HINV(1,3)*QZ P(2,I) = HINV(2,1)*QX + HINV(2,2)*QY + HINV(2,3)*QZ P(3,I) = HINV(3,1)*QX + HINV(3,2)*QY + HINV(3,3)*QZ C QX = Q0(1,I) QY = Q0(2,I) QZ = Q0(3,I) P0(1,I) = HINV(1,1)*QX + HINV(1,2)*QY + HINV(1,3)*QZ P0(2,I) = HINV(2,1)*QX + HINV(2,2)*QY + HINV(2,3)*QZ 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=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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,TDUMP,PDUMP, * STEMP,VSTEMP,PREST(3,3),SPRES(6),PPXYZ(7), * FJMOL, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY 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, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /VECTOR/ FNV(LNV), UNV(LNV), PNV(3,3,LNV), * VEC(3,LNV), ZIA(LEM), ALPHA, UCSELF,UCSLFI(LEM), * MODE, NVN, NVEC(3,LNV) REAL *8 FNV,UNV,PNV,VEC,ZIA,ALPHA,UCSELF 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),RBOX(6), * G(3,3),GINV(3,3),TRANSX(8),TRANSY(8),TRANSZ(8) * ,Q(3,LNI),Q0(3,LNI) REAL *8 H,HINV,G,GINV,RBOX,Q,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, ELC2,ASP,ERFC,PAAV2,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 = 10, 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 KX = IL + 1 - II DO 260 JJ = 1, JL2 KY = JL + 1 - JJ DO 250 KK = 1, KL2 KZ = KK - 1 IF (KZ.GT.0) GO TO 230 IF (KY.LT.0) GO TO 250 IF (KY.EQ.0 .AND. KX.LE.0) GO TO 250 230 XN = HINV(1,1)*KX + HINV(2,1)*KY + HINV(3,1)*KZ YN = HINV(1,2)*KX + HINV(2,2)*KY + HINV(3,2)*KZ ZN = HINV(1,3)*KX + HINV(2,3)*KY + HINV(3,3)*KZ VN2 = XN**2 + YN**2 + ZN**2 IF (VN2.GT.ABC2) GO TO 250 NVN = NVN + 1 IF (NVN.GT.LNV) THEN WRITE (*,9901) ABS(MODE) 9901 FORMAT (' ***** SET [MODE] LESS THAN ',I2, * ' *****') STOP END IF NVEC(1,NVN) = KX NVEC(2,NVN) = KY NVEC(3,NVN) = KZ VEC(1,NVN) = XN VEC(2,NVN) = YN VEC(3,NVN) = ZN XNN = HINV(1,1)*XN + HINV(1,2)*YN + HINV(1,3)*ZN YNN = HINV(2,1)*XN + HINV(2,2)*YN + HINV(2,3)*ZN ZNN = HINV(3,1)*XN + HINV(3,2)*YN + HINV(3,3)*ZN EXPVN = EXP(- VN2 * PIAL2) / VN2 FNV(NVN) = FCT * EXPVN UNV(NVN) = UCT * EXPVN PAAV2 = 2.0D0 * (PIAL2 + 1.0D0/VN2) PCTEXV = PCT * EXPVN PNV(1,1,NVN)= PCTEXV* H(1,1)*(HINV(1,1)-PAAV2*XNN*XN) PNV(2,1,NVN)= PCTEXV* H(1,2)*(HINV(1,2)-PAAV2*XNN*YN) PNV(3,1,NVN)= PCTEXV* H(1,3)*(HINV(1,3)-PAAV2*XNN*ZN) PNV(1,2,NVN)= PCTEXV* H(2,1)*(HINV(2,1)-PAAV2*YNN*XN) PNV(2,2,NVN)= PCTEXV* H(2,2)*(HINV(2,2)-PAAV2*YNN*YN) PNV(3,2,NVN)= PCTEXV* H(2,3)*(HINV(2,3)-PAAV2*YNN*ZN) PNV(1,3,NVN)= PCTEXV* H(3,1)*(HINV(3,1)-PAAV2*ZNN*XN) PNV(2,3,NVN)= PCTEXV* H(3,2)*(HINV(3,2)-PAAV2*ZNN*YN) PNV(3,3,NVN)= PCTEXV* H(3,3)*(HINV(3,3)-PAAV2*ZNN*ZN) 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) = 2.0 * ZIO(IO)**2*ASP 310 CONTINUE RETURN END C C C ======== C================================================================ VWCORR SUBROUTINE VWCORR PARAMETER (LNI=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) C C --------- Correction of energy and pressur for Van der Waals terms C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST(3,3),SPRES(6),PPXYZ(7), * FJMOL, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY 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, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /VECTOR/ FNV(LNV), UNV(LNV), PNV(3,3,LNV), * VEC(3,LNV), ZIA(LEM), ALPHA, UCSELF,UCSLFI(LEM), * MODE, NVN, NVEC(3,LNV) REAL *8 FNV,UNV,PNV,VEC,ZIA,ALPHA,UCSELF 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 /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.0 VCORR = 0.0 N = 0 DO 230 I = 1, NCOMPO DO 220 J = 1, I N = N + 1 SATOMS = NION(I) * NION(J) / VOL * PI4 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 (*,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================================================================ BUSING SUBROUTINE BUSING PARAMETER (LNI=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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,TDUMP,PDUMP, * STEMP,VSTEMP,PREST(3,3),SPRES(6),PPXYZ(7), * FJMOL, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST,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, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY 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,EX,RIJ,ARIJ,ARB C BETA = CAL * 1.0D10 / ANA C N = 0 DO 110 I = 1, NCOMPO II = I DO 100 J = 1, II C N = (II-1)*LEL +J -(2*LEL-II)*(II-1)/2 N = N + 1 ZIJ(N) = ZIO(II)*ZIO(J) 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 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================================================================ MORSEP SUBROUTINE MORSEP PARAMETER (LNI=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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,TDUMP,PDUMP, * STEMP,VSTEMP,PREST(3,3),SPRES(6),PPXYZ(7), * FJMOL, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY 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, * 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 E1M,AM1, RIJ, ELC2,BETA,ARB, EPSIJ(LEF), * F1M,AM2,ARIJ, EX,ZFORML(LEM), 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 C N = (II-1)*LEL +J -(2*LEL-II)*(II-1)/2 N = N + 1 ZIJ(N) = ZIO(II) * ZIO(J) 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.'MORSE-PL '.OR.RUNOPT(8).EQ.'BELONO ') THEN 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 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 = '( 3H I ,9X, 3(5X,A2,1H-,A2),90X,1HI )' FMT2 = '( 3H I ,4X,A4,1X, 3F10.3, 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.3, 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.3, 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.2, 2X,1HI )' ELSE IF (NCOMPO.EQ.6) THEN FMT1 = '( 3H I ,3X, 21(1X,A2,1H-,A2), 1HI )' FMT2 = '( 3H I ,A3, 21F6.2, 1HI )' ELSE IF (NCOMPO.GE.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) '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) 'Rsw ', (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 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 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 - 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=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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,TDUMP,PDUMP, * STEMP,VSTEMP,PREST(3,3),SPRES(6),PPXYZ(7), * FJMOL, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY 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, * 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 E1M,AM1, RIJ, ELC2,BETA,ARB, EPSIJ(LEF), * F1M,AM2,ARIJ, EX,ZFORML(LEM), 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=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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,TDUMP,PDUMP, * STEMP,VSTEMP,PREST(3,3),SPRES(6),PPXYZ(7), * FJMOL, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY 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, * 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 E1M,AM1, RIJ, ELC2,BETA,ARB, EPSIJ(LEF), * F1M,AM2,ARIJ, EX,ZFORML(LEM), SEPij(LEF) real *8 am3, dm3ij(lef), be3ij(lef), r03ij(lef) integer ipara(2,10), npara real *4 apara(8,10) CHARACTER *54 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 C N = (II-1)*LEL +J -(2*LEL-II)*(II-1)/2 N = N + 1 ZIJ(N) = ZIO(II) * ZIO(J) 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 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) 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 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 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 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',19x,'DM1ij BE1ij DM2ij BE2ij', * 7x,'DM3ij BE3ij R03ij Rswch',29x,'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',2x,A2,'(',i1,')-',A2,'(',i1,') ', * 3(F12.3, F10.3),F10.3,F10.3, 29x, '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 ',24X, '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 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=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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,TDUMP,PDUMP, * STEMP,VSTEMP,PREST(3,3),SPRES(6),PPXYZ(7), * FJMOL, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY 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, * 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 E1M,AM1, RIJ, ELC2,BETA,ARB, EPSIJ(LEF), * F1M,AM2,ARIJ, EX,ZFORML(LEM), SEPij(LEF) real *8 am3, dm3ij(lef), be3ij(lef), r03ij(lef) integer ipara(2,10), npara real *4 apara(8,10) CHARACTER *54 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 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================================================================ TOSIFU SUBROUTINE TOSIFU PARAMETER (LNI=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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,TDUMP,PDUMP, * STEMP,VSTEMP,PREST(3,3),SPRES(6),PPXYZ(7), * FJMOL, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY 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, * 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 C N = (II-1)*LEL +J -(2*LEL-II)*(II-1)/2 ZIJ(N) = ZIO(II) * ZIO(J) 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 D4IJ(N) = 0.0 D7IJ(N) = 0.0 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 F1(I,J) = EXPA/BIJ(J)*BETA * 1.0D8 * ARIJ C F1(I,J) = (EXPA/BIJ(J)*BETA - 6.0*CIJ(J)*ARIJ**7 C * - 8.0*DIJ(J)*ARIJ**9) C * * 1.0D8 * ARIJ END IF 240 CONTINUE 250 CONTINUE RETURN END C C C ======== C================================================================ ANGELP SUBROUTINE ANGELP PARAMETER (LNI=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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,TDUMP,PDUMP, * STEMP,VSTEMP,PREST(3,3),SPRES(6),PPXYZ(7), * FJMOL, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY 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, * 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 C BETA = CAL * 1.0E10 / ANA 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 ZIJ(N) = ZIO(II) * ZIO(J) 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 DIJ(N) = 0.0 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 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=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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,TDUMP,PDUMP, * STEMP,VSTEMP,PREST(3,3),SPRES(6),PPXYZ(7), * FJMOL, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY 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, * 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 ZIJ(N) = ZIO(II) * ZIO(J) 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 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=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST(3,3),SPRES(6),PPXYZ(7), * FJMOL, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY 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, * 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(3,3,LNV), * VEC(3,LNV), ZIA(LEM), ALPHA, UCSELF,UCSLFI(LEM), * MODE, NVN, NVEC(3,LNV) REAL *8 FNV,UNV,PNV,VEC,ZIA,ALPHA,UCSELF 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(2) 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) WRITE (16,*) I,INP(I), * E1(JNP-1,J),E1(JNP,J) 470 CONTINUE END IF END IF 450 CONTINUE END IF C IF (IPR.EQ.1) THEN WRITE (*,1001) RCUT(1),AKFI(1),ECORR,VCORR,N3BP 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=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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,TDUMP,PDUMP, * STEMP,VSTEMP,PREST(3,3),SPRES(6),PPXYZ(7), * FJMOL, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY 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, * 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/ VAL(LVA), TVAL(LVA),TVALL(LVA),VALMAX(LVA), * VAL0(LVA),SVAL(LVA),SVALL(LVA),VALMIN(LVA), * AVA(LVA,L50), NAV,NAVT REAL *8 VAL,TVAL,TVALL,VALMAX,VAL0,SVAL,SVALL,VALMIN 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 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(3,3,LNV), * VEC(3,LNV), ZIA(LEM), ALPHA, UCSELF,UCSLFI(LEM), * MODE, NVN, NVEC(3,LNV) REAL *8 FNV,UNV,PNV,VEC,ZIA,ALPHA,UCSELF 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, Pyz, Pxz, Pxy) 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.0D0 SVALL(I) = 0.0D0 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 RETURN END C C C ======== C================================================================ NEWTON SUBROUTINE NEWTON PARAMETER (LNI=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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,TDUMP,PDUMP, * STEMP,VSTEMP,PREST(3,3),SPRES(6),PPXYZ(7), * FJMOL, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY COMMON /CARTES/ H(3,3),HINV(3,3),RBOX(6), * G(3,3),GINV(3,3),TRANSX(8),TRANSY(8),TRANSZ(8) * ,Q(3,LNI),Q0(3,LNI) REAL *8 H,HINV,G,GINV,RBOX,Q,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, * 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(3,3,LNV), * VEC(3,LNV), ZIA(LEM), ALPHA, UCSELF,UCSLFI(LEM), * MODE, NVN, NVEC(3,LNV) REAL *8 FNV,UNV,PNV,VEC,ZIA,ALPHA,UCSELF COMMON /VALUES/ VAL(LVA), TVAL(LVA),TVALL(LVA),VALMAX(LVA), * VAL0(LVA),SVAL(LVA),SVALL(LVA),VALMIN(LVA), * AVA(LVA,L50), NAV,NAVT REAL *8 VAL,TVAL,TVALL,VALMAX,VAL0,SVAL,SVALL,VALMIN 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 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, * 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 PXYZ(7) 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),THETA,COSTH,SINTH, VC(3,LNI) C DO 20 N = 1, N3BP AV3BP(1,N) = 0.0 AV3BP(2,N) = 0.0 20 CONTINUE 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.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 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 c if (runopt(23).eq.'DIATOMIC ') call Center_of_Diatomic_Molecule c 80 CONTINUE 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 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, yz, xz, xy) : 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 : alpha, beta, gamma (in degree) : 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 QXI = H(1,1)*PXI + H(1,2)*PYI + H(1,3)*PZI QYI = H(2,1)*PXI + H(2,2)*PYI + H(2,3)*PZI QZI = H(3,1)*PXI + H(3,2)*PYI + H(3,3)*PZI DIPOLE(1) = DIPOLE(1) + ZIO(IO)*QXI DIPOLE(2) = DIPOLE(2) + ZIO(IO)*QYI DIPOLE(3) = DIPOLE(3) + ZIO(IO)*QZI 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 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 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') 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 C P(1,I) = P(1,I) + V1I * ABOX1 C P(2,I) = P(2,I) + V2I * ABOX2 C P(3,I) = P(3,I) + V3I * ABOX3 Q(1,I) = Q(1,I) + V1I Q(2,I) = Q(2,I) + V2I Q(3,I) = Q(3,I) + V3I 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 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 CALL PTOXYZ (I) 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) IF (IION(IO).GE.0) THEN Q(1,I) = Q(1,I) + V1I Q(2,I) = Q(2,I) + V2I Q(3,I) = Q(3,I) + V3I 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 --------------------------------- Cartesian to crystal coordinates 500 CALL XYZTOP C ------------------------------------------------------- Basic cell DO 640 IO = 1, NCOMPO IF (NION(IO).LE.0) GO TO 640 DO 630 I = IONS(1,IO), IONS(2,IO) DO 620 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 620 CONTINUE 630 CONTINUE 640 CONTINUE C ================================================================== 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 550 I = IS1, IS2 IF (IOND(I).EQ.0) THEN UI(I) = 0.0 GO TO 550 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(2,I) * VC(3,I) VAVB(5) = VAVB(5) + VC(1,I) * VC(3,I) VAVB(6) = VAVB(6) + VC(1,I) * VC(2,I) C ------------------------------------------ For m.s.d. C VALIO2 = VALIO2 + ((P(1,I)-P0(1,I))*BOX(1))**2 C * + ((P(2,I)-P0(2,I))*BOX(2))**2 C * + ((P(3,I)-P0(3,I))*BOX(3))**2 VALIO2 = VALIO2 + (Q(1,I)-Q0(1,I))**2 * + (Q(2,I)-Q0(2,I))**2 * + (Q(3,I)-Q0(3,I))**2 550 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 C ------------------------------------------------------ Temperature VAL(1) = VAL(13) / (1.5D0 * REAL(NTION-NTIOND) * AKB) TINT = TINT + VAL(1) C ----------------------------------------------- Quantum correction IF (RUNOPT(12).EQ.'QUANTUM ') THEN CALL QUANTM END IF C --------------------------------------------------- Coulomb energy VAL(9) = UCSELF + VAL(9) VIRLSR = VIRLSR * 1.0D-8 + VCORR C --------------------------------------------------------- Pressure 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 660 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 660 CONTINUE C --------------------------------------------------------- Energies VAL(10) = VAL(10) + ECORR VAL(12) = VAL(9) + VAL(10) + VAL(11) DO 680 I = 9, 13 VAL(I) = VAL(I) * FJMOL 680 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 C -------------------------------- Pressure control by scaling IF (RUNOPT(6).EQ.'P SCALING ') CALL SCCELL (PXYZ) C ------------------------------------- Stress control (shear) IF (RUNOPT(6).EQ.'P SHEAR ') 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 PRESXX = VAL(3) + DPRES PRESYY = VAL(4) + DPRES PRESZZ = VAL(5) + DPRES VOLS = 1.0D-1*1.0D3*VOL*DTIME**2 C WRITE(*,*) 'VOLS=',VOLS VBOX(1) = VBOX(1) + VOLS*(PRESXX-SPRES(1))*ABOX1/VIRM(1) VBOX(2) = VBOX(2) + VOLS*(PRESYY-SPRES(2))*ABOX2/VIRM(2) VBOX(3) = VBOX(3) + VOLS*(PRESZZ-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 720 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 720 CONTINUE CALL TABLER (0) END IF C --------------------------------------- Constant shear rate (NEMD) IF (RUNOPT(22).EQ.'CONSTSHEAR') CALL CSHEAR C C ------------------------------------- Basic (unit) cell parameters VAL(17) = DENSTY DO 750 I = 1, 6 VAL(I+18) = BOX(I) 750 CONTINUE VAL(18) = VOL * ANA * 1.0E-24 / NFORML IF (RUNOPT(17).EQ.'CRYSTAL ') THEN DO 760 I = 1, 3 VAL(I+18) = BOX(I) / NBOX(I) 760 CONTINUE END IF C ------------------------- cos(x) -> degree DO 780 I = 1, 3 COSTH = BOX(I+3) SINTH = SQRT(DABS(1.0D0 - COSTH*COSTH)) IF (COSTH.NE.0.0) THEN THETA = ATAN(SINTH/COSTH) * 180.0D0/PI ELSE THETA = 90.0 END IF IF (THETA.LT.0.0D0) THETA = THETA + 180.0D0 VAL(I+21) = THETA 780 CONTINUE C C ---------------------------------------------------- Print results CALL PRINTS (DIPM2) C C ------------------------------------- Correction for sum of mv = 0 C (Center of gravity) IF (RUNOPT(16).NE.'NO(MV=0) ') THEN IF (MOD(NRECRD(1),10).EQ.0) THEN DO 810 I = 1, NTION CALL PTOXYZ (I) 810 CONTINUE DO 860 J = 1, 3 CENTRE = 0.0D0 DO 840 IO = 1, NCOMPO IF (NION(IO).GT.0) THEN DO 820 I = IONS(1,IO), IONS(2,IO) CENTRE = CENTRE + V(J,I)*WIO(IO) 820 CONTINUE END IF 840 CONTINUE CENTRE = CENTRE / TWEGHT CENTRP = CENTRE / BOX(J) DO 850 I = 1, NTION IF (IOND(I).GT.0) THEN V(J,I) = V(J,I) - CENTRE C P(J,I) = P(J,I) - CENTRP Q(J,I) = Q(J,I) - CENTRE END IF 850 CONTINUE 860 CONTINUE CALL XYZTOP END IF END IF IF (RUNOPT(21).EQ.'GRAV.FIELD') then DO 811 I = 1, NTION CALL PTOXYZ (I) 811 CONTINUE DO 851 J = 1, 3 CENTRE = 0.0D0 DO 831 IO = 1, NCOMPO IF (NION(IO).GT.0) THEN DO 821 I = IONS(1,IO), IONS(2,IO) CENTRE = CENTRE + V(J,I)*WIO(IO) 821 CONTINUE END IF 831 CONTINUE CENTRE = CENTRE / TWEGHT CENTRP = CENTRE / BOX(J) DO 841 I = 1, NTION IF (IOND(I).GT.0) THEN V(J,I) = V(J,I) - CENTRE c P(J,I) = P(J,I) - CENTRP Q(J,I) = Q(J,I) - CENTRE END IF 841 CONTINUE 851 CONTINUE CALL XYZTOP end if C ----------------------------------- Temperature control by scaling 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.0D0) 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 (DABS(DELTMP).LE.0.00001) 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 880 I = 1, NTION DO 880 J = 1, 3 V(J,I) = V(J,I) * FV 880 CONTINUE END IF END IF 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 --------------------------- Reduce velocities to prevent explosion IF (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 CALL PTOXYZ (I) 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 C P(J,I) = P(J,I) - (1.0D0 - FVI)*V(J,I) / BOX(J) Q(J,I) = Q(J,I) - (1.0D0 - FVI)*V(J,I) V(J,I) = V(J,I) * FVI 940 CONTINUE 950 CONTINUE CALL XYZTOP END IF TPRE = VAL(1) C RETURN C 999 WRITE (*,9988) VAL(1) 9988 FORMAT (' ???????? TEMPERATURE TOO HIGH ',F10.0,'K ????????') STOP END C C C ======== C================================================================ PRINTS SUBROUTINE PRINTS (DIPM2) PARAMETER (LNI=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) C COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST(3,3),SPRES(6),PPXYZ(7), * FJMOL, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY 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, * 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/ VAL(LVA), TVAL(LVA),TVALL(LVA),VALMAX(LVA), * VAL0(LVA),SVAL(LVA),SVALL(LVA),VALMIN(LVA), * AVA(LVA,L50), NAV,NAVT REAL *8 VAL,TVAL,TVALL,VALMAX,VAL0,SVAL,SVALL,VALMIN 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 650 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) C1001 FORMAT (21X,'Average J-I-J angle is ',F6.2,' (',I4,')') 650 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 = '(I5,I5,F7.4,1H(,3F5.2,1H), ' IF (VAL2.GT.9.5 .AND. VAL2.LT.95.0) THEN FMT11 = '(I5,I5,F7.3,1H(,3F5.1,1H), ' ELSE IF (VAL2.GE.95.0) THEN FMT11 = '(I5,I5,F7.2,1H(,3F5.0,1H), ' END IF FMT12 = 'F9.1,F8.1,F6.1,F9.1,F8.5,1H ,I2,1H'',I2)' 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 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 VAL345 = (PRSTC2(1)+PRSTC2(2)+PRSTC2(3))/3 C WRITE (*,9285) (PRSTC2(I),I=1,3),VAL345 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 (AV3BP(2,1).LT.0.1) WRITE (*,2901) (VAL(J+34), * ATOM(J),J=1,5),VAL(19), * VAL(20),VAL(21) IF (AV3BP(2,1).GT.0.1) WRITE (*,2901) (VAL(J+34), * ATOM(J),J=1,5),VAL(19), * VAL(20),VAL(21), * AV3BP(1,1),INT(AV3BP(2,1)) 2901 FORMAT (1X,'Msd:',5(F6.2,':',A1),1X,3F7.3, * F6.1,':',I5) WRITE (*,2904) (VAL(J+34),ATOM(J),J=6,8), VAL(22), * VAL(23),VAL(24) 2904 FORMAT (5X,3(F6.2,':',A1),17X,3F7.3) END IF IF (RUNOPT(17).EQ.'CRYSTAL ') THEN IF (AV3BP(2,1).LT.0.1) WRITE (*,2902) * (VAL(J+34),ATOM(J),J=1,5), VAL(19),VAL(20),VAL(21) IF (AV3BP(2,1).GT.0.1) WRITE (*,2902) * (VAL(J+34),ATOM(J),J=1,5), VAL(19),VAL(20),VAL(21), * AV3BP(1,1),INT(AV3BP(2,1)) 2902 FORMAT (1X,'Msd:',5(F6.3,':',A1),1X,3F7.3, * F6.1,':',I5) WRITE (*,2903) (VAL(J+34),ATOM(J),J=6,7), VAL(22), * VAL(23),VAL(24) 2903 FORMAT (5X,2(F6.3,':',A1),25X,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 = '(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 = '(I5,5I5,F8.3,1H(,6F6.3,1H), ' ELSE IF (VAL2.GE.95.0) THEN FMT11 = '(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,39), (VAL(J),J=19,21), * (VAL(J),J=40,LVA),(VAL(J),J=22,24) 2900 FORMAT (7X,5F8.3,4X,3F9.5 / 7X,5F8.3,4X,3F9.5 ) END IF RETURN END C C C ================ C=======================================================Center_of_DIATOM SUBROUTINE Center_of_Diatomic_Molecule PARAMETER (LNI=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) C =======================================recognize diatomic molecule COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY 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, * 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),RBOX(6), * G(3,3),GINV(3,3),TRANSX(8),TRANSY(8),TRANSZ(8) * ,Q(3,LNI),Q0(3,LNI) REAL *8 H,HINV,G,GINV,RBOX,Q,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, * 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**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) DX = H(1,1)*RX + H(1,2)*RY + H(1,3)*RZ DY = H(2,1)*RX + H(2,2)*RY + H(2,3)*RZ DZ = H(3,1)*RX + H(3,2)*RY + H(3,3)*RZ c DX = RX * BOX(1) c DY = RY * BOX(2) c 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=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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,TDUMP,PDUMP, * STEMP,VSTEMP,PREST(3,3),SPRES(6),PPXYZ(7), * FJMOL, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY 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, * 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(3,3,LNV), * VEC(3,LNV), ZIA(LEM), ALPHA, UCSELF,UCSLFI(LEM), * MODE, NVN, NVEC(3,LNV) REAL *8 FNV,UNV,PNV,VEC,ZIA,ALPHA,UCSELF COMMON /CARTES/ H(3,3),HINV(3,3),RBOX(6), * G(3,3),GINV(3,3),TRANSX(8),TRANSY(8),TRANSZ(8) * ,Q(3,LNI),Q0(3,LNI) REAL *8 H,HINV,G,GINV,RBOX,Q,TRANSX,TRANSY,TRANSZ COMMON /VALUES/ VAL(LVA), TVAL(LVA),TVALL(LVA),VALMAX(LVA), * VAL0(LVA),SVAL(LVA),SVALL(LVA),VALMIN(LVA), * AVA(LVA,L50), NAV,NAVT REAL *8 VAL,TVAL,TVALL,VALMAX,VAL0,SVAL,SVALL,VALMIN 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, * 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, * PRESXX,PRESYY,PRESZZ,PRESYZ,PRESXZ,PRESXY,VAL09,VAL10, * RIJ2, RCUT2, VIRLSR, SCCSS, RD3BP, * RIJ, ECDD, FCDD REAL *8 Q1U2(LSR),Q2U2(LSR),QCEIJ,ANWIO,ANWJO,QS1,QS2 real *8 pjx0,pjy0,pjz0, zije2,zj, pjx,pjy,pjz real *8 arij, arij2, arij3, arij4 real *8 sdx(1357),sdy(1357),sdz(1357), srij2(1357),srij(1357) integer *4 isj(1357) real *8 www(3,lni) c CP REAL *8 AL2PI, ZIJE2, 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,.5623536 / CP DATA EY0,EY1,EY2,EY3,EY4/ 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 PRESXX = 0.0D0 PRESYY = 0.0D0 PRESZZ = 0.0D0 PRESYZ = 0.0D0 PRESXZ = 0.0D0 PRESXY = 0.0D0 VAL09 = 0.0D0 VAL10 = 0.0D0 C DO 50 I = 1, 3 DO 50 J = 1, 3 PREST(J,I) = 0.0D0 50 CONTINUE 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 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 PREST(1,1) = PREST(1,1) + PNV(1,1,IN) * SCCSS PREST(2,1) = PREST(2,1) + PNV(2,1,IN) * SCCSS PREST(3,1) = PREST(3,1) + PNV(3,1,IN) * SCCSS PREST(1,2) = PREST(1,2) + PNV(1,2,IN) * SCCSS PREST(2,2) = PREST(2,2) + PNV(2,2,IN) * SCCSS PREST(3,2) = PREST(3,2) + PNV(3,2,IN) * SCCSS PREST(1,3) = PREST(1,3) + PNV(1,3,IN) * SCCSS PREST(2,3) = PREST(2,3) + PNV(2,3,IN) * SCCSS PREST(3,3) = PREST(3,3) + PNV(3,3,IN) * SCCSS FIX = VEC(1,IN) FIY = VEC(2,IN) FIZ = VEC(3,IN) 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 / DSQRT(PI) CP BETA = CAL * 1.0D10 / ANA 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) IF (PIX.GE.0.5D0) PIX = PIX - 1.0D0 IF (PIY.GE.0.5D0) PIY = PIY - 1.0D0 IF (PIZ.GE.0.5D0) PIZ = PIZ - 1.0D0 FIX = 0.0D0 FIY = 0.0D0 FIZ = 0.0D0 UII = 0.0D0 N1ATOM = 0 nsatom = 0 IF (IO.EQ.JO) J2 = I - 1 do 260 j = j1, j2 DO 250 K = 1, 8 PJX = PX(J) - TRANSX(K) PJY = PY(J) - TRANSY(K) PJZ = PZ(J) - TRANSZ(K) RX = PIX - PJX RY = PIY - PJY RZ = PIZ - PJZ CT - - - - - delete these if-statements for triclinic CC IF (DABS(RX).GT.0.5) RX = RX - DSIGN(1.0D0,RX) CC IF (DABS(RY).GT.0.5) RY = RY - DSIGN(1.0D0,RY) CC IF (DABS(RZ).GT.0.5) RZ = RZ - DSIGN(1.0D0,RZ) DX = H(1,1)*RX + H(1,2)*RY + H(1,3)*RZ DY = H(2,1)*RX + H(2,2)*RY + H(2,3)*RZ DZ = H(3,1)*RX + H(3,2)*RY + H(3,3)*RZ 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 250 CONTINUE 260 continue 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 EIJ = (E0(IP0)*X0 +E0(IP1)*X1 +E0(IP2)*X2)*ZIZJ FIJ = (F0(IP0)*X0 +F0(IP1)*X1 +F0(IP2)*X2)*ZIZJ CE ----------------------- For precise calculations CE ------ FUNCTION ERFC(X) : VERSION 5662 CE ------ in "COMPUTER APPROXIMATIONS" CE Z = DABS(ALPHA * RIJ) CE ERFC = DEXP(-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*DEXP(-(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 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 = DEXP((AIJ(IN) - RIJ) / BIJ(IN)) CS ESIJ = BETA* BIJ(IN)*EX CS FSIJ = BETA* EX CS IF (DMIJ(IN).GT.0.001) THEN CS AM1= DEXP(-2.0D0*BEIJN*(RIJ-RSIJ(IN))) CS AM2= DEXP(-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 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 PRESXX = PRESXX + DFX * DX PRESYY = PRESYY + DFY * DY PRESZZ = PRESZZ + DFZ * DZ PRESYZ = PRESYZ + DFY * DZ PRESXZ = PRESXZ + DFX * DZ PRESXY = PRESXY + DFX * DY 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.3.333333) 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 ///// 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 ///// c write (6,*) io,ijk ///// do 480 i=ions(1,io), ions(2,io) ///// mm = idatom(51,i) ///// 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) = H(1,1)*RX + H(1,2)*RY + H(1,3)*RZ d1axyz(2) = H(2,1)*RX + H(2,2)*RY + H(2,3)*RZ d1axyz(3) = H(3,1)*RX + H(3,2)*RY + H(3,3)*RZ 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) = H(1,1)*RX + H(1,2)*RY + H(1,3)*RZ d2axyz(2) = H(2,1)*RX + H(2,2)*RY + H(2,3)*RZ d2axyz(3) = H(3,1)*RX + H(3,2)*RY + H(3,3)*RZ 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,www) ///// 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,www) ///// end if ///// end if ///// 440 CONTINUE ///// 460 continue ///// 470 continue ///// 480 continue ///// 490 continue ///// end if ///// c if (max_nsatom.gt.1234) write (6,*) 'Max(nsatom)=',max_nsatom max_ddatom = 0 do i=1, ntion if (max_ddatom.lt.idatom(51,i)) max_ddatom = idatom(51,i) end do if (max_ddatom.gt.45) write (6,*) 'max_ddatom =',max_ddatom 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 = ZII(I) * ZII(J) * 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) DX = H(1,1)*RX + H(1,2)*RY + H(1,3)*RZ DY = H(2,1)*RX + H(2,2)*RY + H(2,3)*RZ DZ = H(3,1)*RX + H(3,2)*RY + H(3,3)*RZ c DX = RX * BOX(1) c DY = RY * BOX(2) c 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 PRESXX = PRESXX + DFX * DX PRESYY = PRESYY + DFY * DY PRESZZ = PRESZZ + DFZ * DZ PRESYZ = PRESYZ + DFY * DZ PRESXZ = PRESXZ + DFX * DZ PRESXY = PRESXY + DFX * DY 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 ------------------------------------------------------------------- PRSTC2(1) = PREST(1,1) PRSTC2(2) = PREST(2,2) PRSTC2(3) = PREST(3,3) PRSTC2(4) = (PREST(2,3)+PREST(3,2)) / 2.0 PRSTC2(5) = (PREST(1,3)+PREST(3,1)) / 2.0 PRSTC2(6) = (PREST(1,2)+PREST(2,1)) / 2.0 VAL(3) = VAL(3) + PRESXX*1.0D-8 + PRSTC2(1) VAL(4) = VAL(4) + PRESYY*1.0D-8 + PRSTC2(2) VAL(5) = VAL(5) + PRESZZ*1.0D-8 + PRSTC2(3) VAL(6) = VAL(6) + PRESYZ*1.0D-8 + PRSTC2(4) VAL(7) = VAL(7) + PRESXZ*1.0D-8 + PRSTC2(5) VAL(8) = VAL(8) + PRESXY*1.0D-8 + PRSTC2(6) VAL(9) = VAL(9) + VAL09 VAL(10) = VAL(10) + VAL10 C ---------------------------------------------- Pressure tensor PREST(1,1) = PRESXX*1.0D-8 + PREST(1,1) PREST(2,1) = PRESXY*1.0D-8 + PREST(2,1) PREST(3,1) = PRESXZ*1.0D-8 + PREST(3,1) PREST(1,2) = PRESXY*1.0D-8 + PREST(1,2) PREST(2,2) = PRESYY*1.0D-8 + PREST(2,2) PREST(3,2) = PRESYZ*1.0D-8 + PREST(3,2) PREST(1,3) = PRESXZ*1.0D-8 + PREST(1,3) PREST(2,3) = PRESYZ*1.0D-8 + PREST(2,3) PREST(3,3) = PRESZZ*1.0D-8 + PREST(3,3) C C ------------------------------------ Cancel intramolecular 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. IION(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 (PIX.GE.0.5D0) PIX = PIX - 1.0D0 IF (PIY.GE.0.5D0) PIY = PIY - 1.0D0 IF (PIZ.GE.0.5D0) PIZ = PIZ - 1.0D0 IF (IO.EQ.JO) J2 = I - 1 DO 750 J = J1, J2 DO 740 K = 1, 8 cc DX = ABS(PIX - PX(J)) cc DY = ABS(PIY - PY(J)) cc DZ = ABS(PIZ - PZ(J)) CT - - - - - delete these if-statements for triclinic CC IF (DABS(RX).GT.0.5) RX = 1.0 - RX CC IF (DABS(RY).GT.0.5) RY = 1.0 - RY CC IF (DABS(RZ).GT.0.5) RZ = 1.0 - RZ RX = ABS(PIX - PX(J) + TRANSX(K)) RY = ABS(PIY - PY(J) + TRANSY(K)) RZ = ABS(PIZ - PZ(J) + TRANSZ(K)) DX = H(1,1)*RX + H(1,2)*RY + H(1,3)*RZ DY = H(2,1)*RX + H(2,2)*RY + H(2,3)*RZ DZ = H(3,1)*RX + H(3,2)*RY + H(3,3)*RZ CC RIJ2 = (DX * BOX(1))**2 + (DY * BOX(2))**2 CC * + (DZ * BOX(3))**2 RIJ2 = DX**2 + DY**2 + DZ**2 IF (RIJ2.LE.RCUT2) GO TO 755 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=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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,TDUMP,PDUMP, * STEMP,VSTEMP,PREST(3,3),SPRES(6),PPXYZ(7), * FJMOL, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY 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, * 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(3,3,LNV), * VEC(3,LNV), ZIA(LEM), ALPHA, UCSELF,UCSLFI(LEM), * MODE, NVN, NVEC(3,LNV) REAL *8 FNV,UNV,PNV,VEC,ZIA,ALPHA,UCSELF COMMON /CARTES/ H(3,3),HINV(3,3),RBOX(6), * G(3,3),GINV(3,3),TRANSX(8),TRANSY(8),TRANSZ(8) * ,Q(3,LNI),Q0(3,LNI) REAL *8 H,HINV,G,GINV,RBOX,Q,TRANSX,TRANSY,TRANSZ COMMON /VALUES/ VAL(LVA), TVAL(LVA),TVALL(LVA),VALMAX(LVA), * VAL0(LVA),SVAL(LVA),SVALL(LVA),VALMIN(LVA), * AVA(LVA,L50), NAV,NAVT REAL *8 VAL,TVAL,TVALL,VALMAX,VAL0,SVAL,SVALL,VALMIN 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, * 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(500),D1AXYZ(3,500), ddatom(50,lni), * D2ATOM(500),D2AXYZ(3,500), idatom(51,lni), * N1ATOM,I1ATOM(500), N2ATOM,I2ATOM(500) REAL *8 D1ATOM, D1AXYZ, D2ATOM,D2AXYZ C REAL *8 PIX,DX,RX,DFX,FIX, SICOS, SISIN,R00,X0, * PIY,DY,RY,DFY,FIY,FSICOS,FSISIN,R01,X1,FIJ, * PIZ,DZ,RZ,DFZ,FIZ,USICOS,USISIN,R02,X2,EIJ, * PRESXX,PRESYY,PRESZZ,PRESYZ,PRESXZ,PRESXY,VAL09, * RIJ2, RCUT2, SCCSS, PRESTM(3,3),VAL09C, * RIJ, PI2,PHI,PRSTC2(6) real *8 pjx0,pjy0,pjz0,zije2, PJX,PJY,PJZ, * 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 PRESXX = 0.0D0 PRESYY = 0.0D0 PRESZZ = 0.0D0 PRESYZ = 0.0D0 PRESXZ = 0.0D0 PRESXY = 0.0D0 VAL09 = 0.0D0 VAL09C = 0.0D0 DO 50 I = 1, 3 DO 50 J = 1, 3 PRESTM(J,I) = 0.0D0 50 CONTINUE 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 PRESTM(1,1) = PRESTM(1,1) + PNV(1,1,IN) * SCCSS PRESTM(2,1) = PRESTM(2,1) + PNV(2,1,IN) * SCCSS PRESTM(3,1) = PRESTM(3,1) + PNV(3,1,IN) * SCCSS PRESTM(1,2) = PRESTM(1,2) + PNV(1,2,IN) * SCCSS PRESTM(2,2) = PRESTM(2,2) + PNV(2,2,IN) * SCCSS PRESTM(3,2) = PRESTM(3,2) + PNV(3,2,IN) * SCCSS PRESTM(1,3) = PRESTM(1,3) + PNV(1,3,IN) * SCCSS PRESTM(2,3) = PRESTM(2,3) + PNV(2,3,IN) * SCCSS PRESTM(3,3) = PRESTM(3,3) + PNV(3,3,IN) * SCCSS FIX = VEC(1,IN) FIY = VEC(2,IN) FIZ = VEC(3,IN) 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 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 - - - - - 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) DX = H(1,1)*RX + H(1,2)*RY + H(1,3)*RZ DY = H(2,1)*RX + H(2,2)*RY + H(2,3)*RZ DZ = H(3,1)*RX + H(3,2)*RY + H(3,3)*RZ c DX = RX * BOX(1) c DY = RY * BOX(2) c 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 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 PRESXX = PRESXX + DFX * DX PRESYY = PRESYY + DFY * DY PRESZZ = PRESZZ + DFZ * DZ PRESYZ = PRESYZ + DFY * DZ PRESXZ = PRESXZ + DFX * DZ PRESXY = PRESXY + DFX * DY 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 PRSTC2(1) = PRSTC2(1) - PRESTM(1,1) PRSTC2(2) = PRSTC2(2) - PRESTM(2,2) PRSTC2(3) = PRSTC2(3) - PRESTM(3,3) PRSTC2(4) = PRSTC2(4) - (PRESTM(2,3)+PRESTM(3,2)) / 2.0 PRSTC2(5) = PRSTC2(5) - (PRESTM(1,3)+PRESTM(3,1)) / 2.0 PRSTC2(6) = PRSTC2(6) - (PRESTM(1,2)+PRESTM(2,1)) / 2.0 VAL(3) = VAL(3) - PRESXX*1.0D-8 - PRESTM(1,1) VAL(4) = VAL(4) - PRESYY*1.0D-8 - PRESTM(2,2) VAL(5) = VAL(5) - PRESZZ*1.0D-8 - PRESTM(3,3) VAL(6) = VAL(6) - PRESYZ*1.0D-8 - (PRESTM(2,3)+PRESTM(3,2))/2.0 VAL(7) = VAL(7) - PRESXZ*1.0D-8 - (PRESTM(1,3)+PRESTM(3,1))/2.0 VAL(8) = VAL(8) - PRESXY*1.0D-8 - (PRESTM(1,2)+PRESTM(2,1))/2.0 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) C ------------------------------------------------ Pressure tensor PREST(1,1) = PREST(1,1) - (PRESXX*1.0D-8 + PRESTM(1,1)) PREST(2,1) = PREST(2,1) - (PRESXY*1.0D-8 + PRESTM(2,1)) PREST(3,1) = PREST(3,1) - (PRESXZ*1.0D-8 + PRESTM(3,1)) PREST(1,2) = PREST(1,2) - (PRESXY*1.0D-8 + PRESTM(1,2)) PREST(2,2) = PREST(2,2) - (PRESYY*1.0D-8 + PRESTM(2,2)) PREST(3,2) = PREST(3,2) - (PRESYZ*1.0D-8 + PRESTM(3,2)) PREST(1,3) = PREST(1,3) - (PRESXZ*1.0D-8 + PRESTM(1,3)) PREST(2,3) = PREST(2,3) - (PRESYZ*1.0D-8 + PRESTM(2,3)) PREST(3,3) = PREST(3,3) - (PRESZZ*1.0D-8 + PRESTM(3,3)) RETURN END C C C ===================== C==================================================== EWALD_of_PolyAtoms SUBROUTINE EWALD_of_PolyAtoms (PRSTC2) PARAMETER (LNI=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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,TDUMP,PDUMP, * STEMP,VSTEMP,PREST(3,3),SPRES(6),PPXYZ(7), * FJMOL, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY 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, * 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(3,3,LNV), * VEC(3,LNV), ZIA(LEM), ALPHA, UCSELF,UCSLFI(LEM), * MODE, NVN, NVEC(3,LNV) REAL *8 FNV,UNV,PNV,VEC,ZIA,ALPHA,UCSELF COMMON /CARTES/ H(3,3),HINV(3,3),RBOX(6), * G(3,3),GINV(3,3),TRANSX(8),TRANSY(8),TRANSZ(8) * ,Q(3,LNI),Q0(3,LNI) REAL *8 H,HINV,G,GINV,RBOX,Q,TRANSX,TRANSY,TRANSZ COMMON /VALUES/ VAL(LVA), TVAL(LVA),TVALL(LVA),VALMAX(LVA), * VAL0(LVA),SVAL(LVA),SVALL(LVA),VALMIN(LVA), * AVA(LVA,L50), NAV,NAVT REAL *8 VAL,TVAL,TVALL,VALMAX,VAL0,SVAL,SVALL,VALMIN 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, * 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(500),D1AXYZ(3,500), ddatom(50,lni), * D2ATOM(500),D2AXYZ(3,500), idatom(51,lni), * N1ATOM,I1ATOM(500), N2ATOM,I2ATOM(500) REAL *8 D1ATOM, D1AXYZ, D2ATOM,D2AXYZ C REAL *8 PIX,DX,RX,DFX,FIX, SICOS, SISIN,R00,X0, * PIY,DY,RY,DFY,FIY,FSICOS,FSISIN,R01,X1,FIJ, * PIZ,DZ,RZ,DFZ,FIZ,USICOS,USISIN,R02,X2,EIJ, * PRESXX,PRESYY,PRESZZ,PRESYZ,PRESXZ,PRESXY,VAL09, * RIJ2, RCUT2, SCCSS, PRESTM(3,3),VAL09C, * RIJ, PI2,PHI,PRSTC2(6) real *8 pjx0,pjy0,pjz0,zije2,zj, PJX,PJY,PJZ, * 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 PRESXX = 0.0D0 PRESYY = 0.0D0 PRESZZ = 0.0D0 PRESYZ = 0.0D0 PRESXZ = 0.0D0 PRESXY = 0.0D0 VAL09 = 0.0D0 VAL09C = 0.0D0 DO 50 I = 1, 3 DO 50 J = 1, 3 PRESTM(J,I) = 0.0D0 50 CONTINUE C C ------------------------------------------ Coulomb reciprocal term C do 999 ijkl = 1, nmole do 977 N=1, mmole(ijkl) I = IMOLE(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 PRESTM(1,1) = PRESTM(1,1) + PNV(1,1,IN) * SCCSS PRESTM(2,1) = PRESTM(2,1) + PNV(2,1,IN) * SCCSS PRESTM(3,1) = PRESTM(3,1) + PNV(3,1,IN) * SCCSS PRESTM(1,2) = PRESTM(1,2) + PNV(1,2,IN) * SCCSS PRESTM(2,2) = PRESTM(2,2) + PNV(2,2,IN) * SCCSS PRESTM(3,2) = PRESTM(3,2) + PNV(3,2,IN) * SCCSS PRESTM(1,3) = PRESTM(1,3) + PNV(1,3,IN) * SCCSS PRESTM(2,3) = PRESTM(2,3) + PNV(2,3,IN) * SCCSS PRESTM(3,3) = PRESTM(3,3) + PNV(3,3,IN) * SCCSS FIX = VEC(1,IN) FIY = VEC(2,IN) FIZ = VEC(3,IN) 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 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 - - - - - 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) DX = H(1,1)*RX + H(1,2)*RY + H(1,3)*RZ DY = H(2,1)*RX + H(2,2)*RY + H(2,3)*RZ DZ = H(3,1)*RX + H(3,2)*RY + H(3,3)*RZ c DX = RX * BOX(1) c DY = RY * BOX(2) c 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 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 PRESXX = PRESXX + DFX * DX PRESYY = PRESYY + DFY * DY PRESZZ = PRESZZ + DFZ * DZ PRESYZ = PRESYZ + DFY * DZ PRESXZ = PRESXZ + DFX * DZ PRESXY = PRESXY + DFX * DY 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 PRSTC2(1) = PRSTC2(1) - PRESTM(1,1) PRSTC2(2) = PRSTC2(2) - PRESTM(2,2) PRSTC2(3) = PRSTC2(3) - PRESTM(3,3) PRSTC2(4) = PRSTC2(4) - (PRESTM(2,3)+PRESTM(3,2)) / 2.0 PRSTC2(5) = PRSTC2(5) - (PRESTM(1,3)+PRESTM(3,1)) / 2.0 PRSTC2(6) = PRSTC2(6) - (PRESTM(1,2)+PRESTM(2,1)) / 2.0 VAL(3) = VAL(3) - PRESXX*1.0D-8 - PRESTM(1,1) VAL(4) = VAL(4) - PRESYY*1.0D-8 - PRESTM(2,2) VAL(5) = VAL(5) - PRESZZ*1.0D-8 - PRESTM(3,3) VAL(6) = VAL(6) - PRESYZ*1.0D-8 - (PRESTM(2,3)+PRESTM(3,2))/2.0 VAL(7) = VAL(7) - PRESXZ*1.0D-8 - (PRESTM(1,3)+PRESTM(3,1))/2.0 VAL(8) = VAL(8) - PRESXY*1.0D-8 - (PRESTM(1,2)+PRESTM(2,1))/2.0 VAL(9) = VAL(9) - VAL09 do ii = MOLstart(1), MOLend(1) VAL(9) = VAL(9) - UCSLFI(II) end do C ------------------------------------------------ Pressure tensor PREST(1,1) = PREST(1,1) - (PRESXX*1.0D-8 + PRESTM(1,1)) PREST(2,1) = PREST(2,1) - (PRESXY*1.0D-8 + PRESTM(2,1)) PREST(3,1) = PREST(3,1) - (PRESXZ*1.0D-8 + PRESTM(3,1)) PREST(1,2) = PREST(1,2) - (PRESXY*1.0D-8 + PRESTM(1,2)) PREST(2,2) = PREST(2,2) - (PRESYY*1.0D-8 + PRESTM(2,2)) PREST(3,2) = PREST(3,2) - (PRESYZ*1.0D-8 + PRESTM(3,2)) PREST(1,3) = PREST(1,3) - (PRESXZ*1.0D-8 + PRESTM(1,3)) PREST(2,3) = PREST(2,3) - (PRESYZ*1.0D-8 + PRESTM(2,3)) PREST(3,3) = PREST(3,3) - (PRESZZ*1.0D-8 + PRESTM(3,3)) RETURN END C C C ======= C================================================================ THREEP SUBROUTINE THREEP (I,j,k, KK3BP, VIRLSR) PARAMETER (LNI=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY 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, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /VALUES/ VAL(LVA), TVAL(LVA),TVALL(LVA),VALMAX(LVA), * VAL0(LVA),SVAL(LVA),SVALL(LVA),VALMIN(LVA), * AVA(LVA,L50), NAV,NAVT REAL *8 VAL,TVAL,TVALL,VALMAX,VAL0,SVAL,SVALL,VALMIN 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, AR, 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 c write (6,*) ffx1, ffy1, ffz1 c write (6,*) ffx2, ffy2, ffz2 c write (6,*) ffx, ffy, ffz c write (6,*) ffx+ffx1+ffx2, ffy+ffy1+ffy2, ffz+ffz1+ffz2 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, WWW) ///// PARAMETER (LNI=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) C C ------------------------------- 3-body potential model j-i-k (j Nirin] ----- C PARAMETER (LNI=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) COMMON /COUNTS/ NJOB(2),IRECRD(9),NRECRD(9),IHISTR(4,111),PVMULT COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST(3,3),SPRES(6),PPXYZ(7), * FJMOL, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST,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, * 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), STRT(3), MEFD REAL *8 EFD, EFREQ, GFD, STRT 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=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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, * 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), STRT(3), MEFD REAL *8 EFD, EFREQ, GFD, STRT c REAL *8 GFDX,GFDY,GFDZ c C ------ g = 9.8 m/s2 = 980 cm/s2 g = 980.665 * 1.0E8 c c write(6,*) GFD GFDX = GFD(1) * g GFDY = GFD(2) * g GFDZ = GFD(3) * g c write (6,*) fx(1),fy(1),fz(1) 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================================================================ CSHEAR SUBROUTINE CSHEAR C C ---------------------------------------- Constant shear rate ----- C PARAMETER (LNI=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) c COMMON /TEMPRS/ DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST(3,3),SPRES(6),PPXYZ(7), * FJMOL, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY COMMON /CARTES/ H(3,3),HINV(3,3),RBOX(6), * G(3,3),GINV(3,3),TRANSX(8),TRANSY(8),TRANSZ(8) * ,Q(3,LNI),Q0(3,LNI) REAL *8 H,HINV,G,GINV,RBOX,Q,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, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP 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), STRT(3), MEFD REAL *8 EFD, EFREQ, GFD, STRT c C -------- SHEAR RATE = STRT(ps-1)*1E12 -> (s-1) SHRXY = STRT(1)*1.0D12 SHRYZ = STRT(2)*1.0D12 SHRXZ = STRT(3)*1.0D12 c aa = sqrt( H(1,1)**2 + H(2,1)**2 + H(3,1)**2 ) bb = sqrt( H(1,2)**2 + H(2,2)**2 + H(3,2)**2 ) cc = sqrt( H(1,3)**2 + H(2,3)**2 + H(3,3)**2 ) c ----------------------------------------------------- dvx/dry H(1,2) = H(1,2) + H(1,1)/aa * SHRXY*(1.0/rbox(2)) * DTIME H(2,2) = H(2,2) + H(2,1)/aa * SHRXY*(1.0/rbox(2)) * DTIME H(3,2) = H(3,2) + H(3,1)/aa * SHRXY*(1.0/rbox(2)) * DTIME c ----------------------------------------------------- dvy/drz H(1,3) = H(1,3) + H(1,2)/bb * SHRYZ*(1.0/rbox(3)) * DTIME H(2,3) = H(2,3) + H(2,2)/bb * SHRYZ*(1.0/rbox(3)) * DTIME H(3,3) = H(3,3) + H(3,2)/bb * SHRYZ*(1.0/rbox(3)) * DTIME c ----------------------------------------------------- dvx/drz H(1,3) = H(1,3) + H(1,1)/aa * SHRXZ*(1.0/rbox(3)) * DTIME H(2,3) = H(2,3) + H(2,1)/aa * SHRXZ*(1.0/rbox(3)) * DTIME H(3,3) = H(3,3) + H(3,1)/aa * SHRXZ*(1.0/rbox(3)) * DTIME C CALL TMATRX (1) CALL TABLER (0) c write (6,*) strt c write (6,*) 'CSHEAR',H(1,3),H(2,3),H(3,3) END C C C ======= C================================================================ SCCELL SUBROUTINE SCCELL (PXYZ) PARAMETER (LNI=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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,TDUMP,PDUMP, * STEMP,VSTEMP,PREST(3,3),SPRES(6),PPXYZ(7), * FJMOL, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY COMMON /CARTES/ H(3,3),HINV(3,3),RBOX(6), * G(3,3),GINV(3,3),TRANSX(8),TRANSY(8),TRANSZ(8) * ,Q(3,LNI),Q0(3,LNI) REAL *8 H,HINV,G,GINV,RBOX,Q,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 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) REAL *8 FA(6), FK, DFV, DDD, HK, * APXYZ,ASPRES,VOLOLD, AROOT2 C AROOT2 = 1.0D0 / SQRT(2.0D0) C IF (RUNOPT(6).NE.'P SCALING ' .AND. * RUNOPT(6).NE.'P SHEAR ' .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 VOLOLD = VOL DDD = 0.001D0 * 512.0D0 C - - - - - - - - - - - - - - Scaling cell edge lengths, A, B, and C DO 70 I = 1, 3 FK = ATAN((PXYZ(I+1) - SPRES(I)) * VBOX(1)*DDD) / 512.0D0 FA(I) = 1.0D0 + FK*5.0*PDUMP DO 70 J = 1, 3 H(I,J) = H(I,J) * FA(I) 70 CONTINUE C - - - - - - - - - - - - - - Scaling angles, alpha, beta, and gamma DO 75 I = 4, 6 FK = ATAN((PXYZ(I+1) - SPRES(I)) * VBOX(1)*DDD) / 512.0D0 FA(I) = FK K1 = 2 K2 = 3 IF (I.EQ.5) THEN K1 = 1 K2 = 3 ELSE IF (I.EQ.6) THEN K1 = 1 K2 = 2 END IF DO 75 J = 1, 3 HK = (H(K1,J)*AROOT2 + H(K2,J)*AROOT2) * FA(I)*PDUMP H(K1,J) = H(K1,J) + HK*AROOT2 H(K2,J) = H(K2,J) + HK*AROOT2 75 CONTINUE CALL TMATRX (1) C DO 80 I = 1, 7 PPXYZ(I) = PXYZ(I) 80 CONTINUE C ------------------------------------------------- Constant density IF (RUNOPT(7).EQ.'D CONST. ') THEN DFV = (VOLOLD / VOL)**(1.0/3.0) DO 90 I = 1, 3 BOX(I) = BOX(I) * DFV DO 90 J = 1, 3 H(J,I) = H(J,I) * DFV 90 CONTINUE CALL TMATRX (1) END IF C CALL TABLER (0) RETURN END C C C ========= C=============================================================== RECORD9 SUBROUTINE RECORD9 PARAMETER (LNI=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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,TDUMP,PDUMP, * STEMP,VSTEMP,PREST(3,3),SPRES(6),PPXYZ(7), * FJMOL, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY 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, * 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),RBOX(6), * G(3,3),GINV(3,3),TRANSX(8),TRANSY(8),TRANSZ(8) * ,Q(3,LNI),Q0(3,LNI) REAL *8 H,HINV,G,GINV,RBOX,Q,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 COMMON /VALUES/ VAL(LVA), TVAL(LVA),TVALL(LVA),VALMAX(LVA), * VAL0(LVA),SVAL(LVA),SVALL(LVA),VALMIN(LVA), * AVA(LVA,L50), NAV,NAVT REAL *8 VAL,TVAL,TVALL,VALMAX,VAL0,SVAL,SVALL,VALMIN 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 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), ((H(J,I),J=1,3),I=1,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), * ((H(J,I),J=1,3),I=1,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 IF (RUNOPT(18).EQ.'BINARY ') THEN WRITE (19) NRECRD(4),((H(J,I),J=1,3),I=1,3) WRITE (19) ((PPK(J,I),J=1,3),I=1,NPTP) ELSE WRITE (19,9001) NRECRD(4), * ((H(J,I),J=1,3),I=1,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,9001) NRECRD(1), H WRITE (28,9002)((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), H 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=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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,TDUMP,PDUMP, * STEMP,VSTEMP,PREST(3,3),SPRES(6),PPXYZ(7), * FJMOL, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY 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, * 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/ VAL(LVA), TVAL(LVA),TVALL(LVA),VALMAX(LVA), * VAL0(LVA),SVAL(LVA),SVALL(LVA),VALMIN(LVA), * AVA(LVA,L50), NAV,NAVT REAL *8 VAL,TVAL,TVALL,VALMAX,VAL0,SVAL,SVALL,VALMIN 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 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 *36 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) C REAL *8 TVV(LVA),TSS(LVA) INTEGER *4 ISDV(11),IVMIN(11),ITSS(11),IAVA(11),ITVV(11), * IVMAX(11) REAL *8 X, Y, TBOX(6),TRBOX(6), COSA(3),SINA(3) 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.0.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,2HK+,5I5,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,2HK+,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), ' FMT21 = '(i3,2HK+,5I5,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 = '(1X,I5,5I5,F8.2,1H(,6F6.1,1H), ' END IF WRITE (16,2105) WRITE (16,FMT1) NAVT, (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 (2x,'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 (9X,'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 (9X,'Effective temperature in quantum correction', * ' is ',F7.2, ' K') END IF WRITE (16,2105) C ------------------------------------------ Basic cell edge lengths WRITE (16,4038) 4038 FORMAT (1X) STRING = '[ MD basic cell ] ' IF (RUNOPT(17).EQ.'CRYSTAL ') STRING = '[ crystal unit cell ]' WRITE (16,4039) 4039 FORMAT ('I',75('-'),'I') WRITE (16,4000) STRING, * (TVALL(I), SVALL(I), VALMIN(I), VALMAX(I), * TVALL(I+3),SVALL(I+3),VALMIN(I+3),VALMAX(I+3), * I=19,21) 4000 FORMAT ('I Cell dimensions (Angstrom, degree)',10X,A21,9X,'I' * /'I A:', F8.5,'(',F6.5,')',F7.4,'-',F7.4,2X, * 'Alpha:',F8.4,'(',F6.4,')',F7.3,'-',F7.3,' I', * /'I B:', F8.5,'(',F6.5,')',F7.4,'-',F7.4,2X, * 'Beta :',F8.4,'(',F6.4,')',F7.3,'-',F7.3,' I', * /'I C:', F8.5,'(',F6.5,')',F7.4,'-',F7.4,2X, * 'Gamma:',F8.4,'(',F6.4,')',F7.3,'-',F7.3,' I') C --------------------------------------- Average reciprocal lattice DO 510 I = 1, 6 TBOX(I) = TVALL(I+18) 510 CONTINUE DO 520 I = 1, 3 COSA(I) = TBOX(I+3) IF (TBOX(I+3).GT.1.0) THEN COSA(I) = COS(TBOX(I+3)*PI/180.0D0) TBOX(I+3) = COSA(I) END IF SINA(I) = SQRT(1.0D0 - COSA(I)**2) 520 CONTINUE VOL = TBOX(1)*TBOX(2)*TBOX(3) * SQRT(1.0 -COSA(1)**2 -COSA(2)**2 * -COSA(3)**2 + 2.0*COSA(1)*COSA(2)*COSA(3)) TRBOX(1) = TBOX(2)*TBOX(3)*SINA(1) / VOL TRBOX(2) = TBOX(1)*TBOX(3)*SINA(2) / VOL TRBOX(3) = TBOX(1)*TBOX(2)*SINA(3) / VOL TRBOX(4) = (COSA(2)*COSA(3)-COSA(1)) / (SINA(2)*SINA(3)) TRBOX(5) = (COSA(1)*COSA(3)-COSA(2)) / (SINA(1)*SINA(3)) TRBOX(6) = (COSA(1)*COSA(2)-COSA(3)) / (SINA(1)*SINA(2)) DO 530 I = 1, 3 SINTHT = SQRT(1.0 - TRBOX(I+3)**2) THT = ATAN(SQRT(SINTHT) / TRBOX(I+3)) * 180.0/PI IF (THT.LT.0.0) THT = THT + 180.0 TRBOX(I+3) = THT 530 CONTINUE WRITE (16,4039) WRITE (16,4070) (TRBOX(I),I=1,6) 4070 FORMAT (1X, 'A*=',F9.7,' B*=',F9.7,' C*=',F9.7, * ' aA*=',F7.3,' aB*=',F7.3,' aC*=',F7.3 ) C 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) FL = 10 IF (VALMAX(I+34).GE.100) FL = 100 405 CONTINUE FMT21 = '(8HI M.s.d. ' FMT22 = '2(3X,A2, 1H:, F6.3, 1H(, F5.3,1H), ' FMT23 = ' F6.3,1H-, F6.3,2X), 1HI ) ' IF (FL.GE.10) THEN FMT22 = '2(3X,A2, 1H:, F6.2, 1H(, F5.2,1H), ' FMT23 = ' F6.2,1H-, F6.2,2X), 1HI ) ' 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 2001 FORMAT (1X) 2100 FORMAT (132('-')) 2105 FORMAT (132('=')) END C C C ======== C================================================================ SUMMRY SUBROUTINE SUMMRY PARAMETER (LNI=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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,TDUMP,PDUMP, * STEMP,VSTEMP,PREST(3,3),SPRES(6),PPXYZ(7), * FJMOL, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY 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, * NTIOND,NIOND(LEM), IOND(LNI), NPAIR, IION(LEM) REAL *8 P,V,VP,P0,UI,AU,AV3BP COMMON /VALUES/ VAL(LVA), TVAL(LVA),TVALL(LVA),VALMAX(LVA), * VAL0(LVA),SVAL(LVA),SVALL(LVA),VALMIN(LVA), * AVA(LVA,L50), NAV,NAVT REAL *8 VAL,TVAL,TVALL,VALMAX,VAL0,SVAL,SVALL,VALMIN 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 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 *21 STRING CHARACTER *40 FMT1(2),FMT11,FMT12 EQUIVALENCE (FMT1(1),FMT11), (FMT1(2),FMT12) C REAL *8 X, Y, TBOX(6),TRBOX(6), COSA(3),SINA(3) DATA HEAD / 'Ave' , 'Sgm'/ STD(X,Y,I) = SQRT(ABS(X - Y**2/DBLE(I))/DBLE(I)) C IF (IRECRD(1).LE.0) RETURN C WRITE (16,2001) WRITE (16,2100) WRITE (16,2452) 2452 FORMAT (' N50 Temp P/GPa ( Pxx, Pyy, Pzz, Pyz, ', * 'Pxz, Pxy ) 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 C ------------------------------------------ Basic cell edge lengths STRING = '[ MD basic cell ] ' IF (RUNOPT(17).EQ.'CRYSTAL ') STRING = '[ crystal unit cell ]' WRITE (16,2001) WRITE (16,4039) 4039 FORMAT ('I',75('-'),'I') WRITE (16,4000) STRING, * (TVAL(I),SVAL(I),TVAL(I+3),SVAL(I+3), I=19,21) 4000 FORMAT ('I Cell dimensions (Angstrom, degree)',10X,A21,9X,'I' * /'I A(X):', F9.5,' (+-',F7.5,')',6X, * 'Alpha(B-C):',F9.4,' (+-',F6.4,')',' I', * /'I B(Y):', F9.5,' (+-',F7.5,')',6X, * 'Beta (A-C):',F9.4,' (+-',F6.4,')',' I', * /'I C(Z):', F9.5,' (+-',F7.5,')',6X, * 'Gamma(A-B):',F9.4,' (+-',F6.4,')',' I') C -------------------------------------------------------- Energies WRITE (16,4039) 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) (TITLE(I),I=1,15), * 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 ( / 6X,15A4 / 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('=') ) C --------------------------------------- Average reciprocal lattice DO 510 I = 1, 6 TBOX(I) = TVAL(I+18) 510 CONTINUE DO 520 I = 1, 3 COSA(I) = TBOX(I+3) IF (TBOX(I+3).GT.1.0) THEN COSA(I) = COS(TBOX(I+3)*PI/180.0D0) TBOX(I+3) = COSA(I) END IF SINA(I) = SQRT(1.0D0 - COSA(I)**2) 520 CONTINUE VOL = TBOX(1)*TBOX(2)*TBOX(3) * SQRT(1.0 -COSA(1)**2 -COSA(2)**2 * -COSA(3)**2 + 2.0*COSA(1)*COSA(2)*COSA(3)) TRBOX(1) = TBOX(2)*TBOX(3)*SINA(1) / VOL TRBOX(2) = TBOX(1)*TBOX(3)*SINA(2) / VOL TRBOX(3) = TBOX(1)*TBOX(2)*SINA(3) / VOL TRBOX(4) = (COSA(2)*COSA(3)-COSA(1)) / (SINA(2)*SINA(3)) TRBOX(5) = (COSA(1)*COSA(3)-COSA(2)) / (SINA(1)*SINA(3)) TRBOX(6) = (COSA(1)*COSA(2)-COSA(3)) / (SINA(1)*SINA(2)) DO 530 I = 1, 3 SINTHT = SQRT(1.0 - TRBOX(I+3)**2) THT = ATAN(SQRT(SINTHT) / TRBOX(I+3)) * 180.0/PI IF (THT.LT.0.0) THT = THT + 180.0 TRBOX(I+3) = THT 530 CONTINUE WRITE (16,4070) (TRBOX(I),I=1,6) 4070 FORMAT (1X, 'A*=',F9.7,' B*=',F9.7,' C*=',F9.7, * ' aA*=',F7.3,' aB*=',F7.3,' aC*=',F7.3 /78('=') ) C RETURN 2001 FORMAT (1X) 2100 FORMAT (132('-')) 2105 FORMAT (132('=')) END C C C ======== C================================================================ PCFRCN SUBROUTINE PCFRCN PARAMETER (LNI=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY 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, * 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 = '(48(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 = '(6X, 15(3X,A2,1H-,A2)) ' FORM2 = '(6H R /A , 15(8H pcf rcn) ) ' FORM3 = '(1X,F5.3, 15(I4,I4),F6.2) ' FORM4 = '(127(1H-) ) ' ELSE IF (NCOMPO.EQ.6) THEN IMULT = 10 FORM1 = '(6X, 21(1X,A2,1H-,A2)) ' FORM2 = '(6H R /A , 21(6H pc cn) ) ' FORM3 = '(1X,F4.2,1X,21(I3,I3),F6.2) ' FORM4 = '(132(1H-) ) ' ELSE IF (NCOMPO.GE.7) THEN IMULT = 10 FORM1 = '(6X, 21(1X,A2,1H-,A2)) ' FORM2 = '(6H R /A , 21(6H pc cn) ) ' FORM3 = '(1X,F4.2,1X,28(I3,I3),F6.2) ' FORM4 = '(132(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,7) 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,7) END IF C RETURN END C C C ======== C================================================================ POTPLT SUBROUTINE POTPLT PARAMETER (LNI=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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, * 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 and displacements 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) NNN = NCOMPO if (NNN.gt.6) NNN = 6 WRITE (16,4000) (ATOM(I), UAV(I), UMIN(I),UMAX(I), I=1,NNN) 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=10,NCOMPO) 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 IO = 1, NCOMPO IF (IION(IO).GT.-998) THEN IF (NSTAT(J,IO).GE.NP) IGRAPH(J) = ATOM(IO) 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) IUOMIN = UOMIN - 0.999999 IUOMAX = UOMAX IF (UOMAX.GT.0.0) IUOMAX = UOMAX + 0.999999 UR = 131.0 / (IUOMAX - IUOMIN) MUP = 0 J1 = IONS(1,1) J2 = IONS(2,1) DO 520 J = J1, J2 JU = (BU(J) - IUOMIN) * 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) IUOMIN, IUOMAX 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=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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,TDUMP,PDUMP, * STEMP,VSTEMP,PREST(3,3),SPRES(6),PPXYZ(7), * FJMOL, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY 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 *4 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) (BOX(I)/NBOX(I),NBOX(I),I=1,3), * NSYM, HEX, (BOX(I),I=4,6) 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) = DSQRT(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 C 3003 FORMAT (/'***',I4,'-',I2,' *** ',15A4,' ***') 3020 FORMAT (/'MD-derived average atomic coordinates in unit cell(s)', * ' (standard deviations, A^2), ',5X, * 3(F8.4,'(X',I2,')') / * ' and experimentally determined ones (number of ', * 'symmetry operations=',I3,1X,A4,') ', * 9X, 3(F9.5,4X) ) 3030 FORMAT (4(2X,I3,F6.3,'(',I2,')',F5.3,'(',I2,')',F5.3,'(',I2,')')) 3060 FORMAT (1X,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=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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,TDUMP,PDUMP, * STEMP,VSTEMP,PREST(3,3),SPRES(6),PPXYZ(7), * FJMOL, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY 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, * 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/ VAL(LVA), TVAL(LVA),TVALL(LVA),VALMAX(LVA), * VAL0(LVA),SVAL(LVA),SVALL(LVA),VALMIN(LVA), * AVA(LVA,L50), NAV,NAVT REAL *8 VAL,TVAL,TVALL,VALMAX,VAL0,SVAL,SVALL,VALMIN 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 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), NNC(7,2) REAL *8 ANBR(8,2), RVEC(3,10,LST) CHARACTER *4 CCHAR(8), ATAB(LST) CHARACTER *6 ACHAR(5) DATA ACHAR / '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 (ATOM(3).EQ.ATMNET(1).OR.ATOM(3).EQ.ATMNET(2)) MMM = IONS(2,3) 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.20 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 (11X,'*** ',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, RVEC, IPR) IF (IT.EQ.0) GO TO 210 NTJ = 0 DO 250 IJ = I0, II NTJ = NTJ + 1 DO 250 J1 = 1, 5 ID1 = IONB(J1,IJ) DB1 = DONB(J1,IJ) IF (DB1.GT.RTO(IT).OR.DB1.LT.0.1) GO TO 250 DB4 = DONB(4,IJ) IF (DB4.GT.RTO(IT).OR.DB4.LT..1) GO TO 230 IF (J1.GT.4) GO TO 230 DTO(IT) = DTO(IT) + DB1 NTO(IT) = NTO(IT) + 1 230 DO 240 J2 = J1+1, 6 ID2 = IONB(J2,IJ) DB2 = DONB(J2,IJ) IF (DB2.GT.RTO(IT).OR.DB2.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,DB1,DB2,ITT, * RVEC, NTJ,J1,J2) 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 (11X,'*** ',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, RVEC, 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 DB1 = DONB(1,IJ) DB2 = DONB(2,IJ) IF (DB2.GT.RTO(2) .OR. DB2.LT.0.01) GO TO 425 IF (DB2.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.[NC]',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) END C C C ======= C================================================================ DISTAN SUBROUTINE DISTAN (I1, I2, IO, RVEC, IPR) PARAMETER (LNI=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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,TDUMP,PDUMP, * STEMP,VSTEMP,PREST(3,3),SPRES(6),PPXYZ(7), * FJMOL, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY COMMON /CARTES/ H(3,3),HINV(3,3),RBOX(6), * G(3,3),GINV(3,3),TRANSX(8),TRANSY(8),TRANSZ(8) * ,Q(3,LNI),Q0(3,LNI) REAL *8 H,HINV,G,GINV,RBOX,Q,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, * 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), RV(3,64), RVEC(3,10,LST) 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 290 I = I1, I2 NI = NI + 1 NB = 0 PIX = PX(I) PIY = PY(I) PIZ = PZ(I) IF (PIX.GE.0.5) PIX = PIX - 1.0 IF (PIY.GE.0.5) PIY = PIY - 1.0 IF (PIZ.GE.0.5) PIZ = PIZ - 1.0 DO 20 J = 1, 64 ID(J) = 0 D(J) = 0.000001 20 CONTINUE DO 170 JO = 1, NCOMPO IF (IION(JO).LE.-999) GO TO 170 IF (NION(JO).LE.0.OR.ZIO(IO)*ZIO(JO).GT.0.0) GO TO 170 DO 150 J = IONS(1,JO), IONS(2,JO) IF (IOND(J).EQ.0 .OR. I.EQ.J) GO TO 150 DO 130 K = 1, 8 RX = PIX - PX(J) + TRANSX(K) RY = PIY - PY(J) + TRANSY(K) RZ = PIZ - PZ(J) + TRANSZ(K) DX = H(1,1)*RX + H(1,2)*RY + H(1,3)*RZ DY = H(2,1)*RX + H(2,2)*RY + H(2,3)*RZ DZ = H(3,1)*RX + H(3,2)*RY + H(3,3)*RZ RIJ2 = DX**2 + DY**2 + DZ**2 IF (RIJ2.LE.9.0) GO TO 140 130 CONTINUE GO TO 150 C CC RX = ABS(PIX-PX(J)) CC RY = ABS(PIY-PY(J)) CC RZ = ABS(PIZ-PZ(J)) CC IF (RX.GT.0.5) RX = 1.0 - DX CC IF (RY.GT.0.5) RY = 1.0 - DY CC IF (RZ.GT.0.5) RZ = 1.0 - DZ CC RIJ2 = (RX*ABOXX)**2 +(RY*ABOXY)**2 +(RZ*ABOXZ)**2 C 140 IF (RIJ2.LE.9.0.AND.NB.LT.64) THEN NB = NB +1 D(NB) = SQRT(RIJ2) ID(NB) = J RV(1,NB) = RX RV(2,NB) = RY RV(3,NB) = RZ END IF 150 CONTINUE 170 CONTINUE IF (NB.GT.1) THEN DO 220 J=1, NB-1 DO 210 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 DO 205 L = 1, 3 DR = RV(L,J) RV(L,J) = RV(L,K) RV(L,K) = DR 205 CONTINUE END IF 210 CONTINUE 220 CONTINUE END IF DO 270 J = 1, 10 ITAB(J,NI) = ID(J) DTAB(J,NI) = D(J) 270 continue do 272 j = 1, 6 DONB(J,I) = D(J) IONB(J,I) = ID(J) RVEC(1,J,NI) = RV(1,J) RVEC(2,J,NI) = RV(2,J) RVEC(3,J,NI) = RV(3,J) 272 CONTINUE do 275 j = 1, 10 idtab(j,ni) = dtab(j,ni) * 100.0 + 0.5 275 continue IU(NI) = AU(I) * 1.E12 / NRECRD(2) + 0.5 290 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 340 I = 1, 10 ITA = 0 DO 320 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) 320 CONTINUE C IF (ITA.LT.1) RETURN IF (ITA.LT.1) GO TO 340 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 340 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,DB1,DB2,IT, * RVEC, NTJ, J1,J2 ) PARAMETER (LNI=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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,TDUMP,PDUMP, * STEMP,VSTEMP,PREST(3,3),SPRES(6),PPXYZ(7), * FJMOL, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY 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, * 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 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 REAL *8 RVEC(3,10,LST) C W = RVEC(1,J1,NTJ)*RVEC(1,J2,NTJ)*BOX(1)**2 + * RVEC(2,J1,NTJ)*RVEC(2,J2,NTJ)*BOX(2)**2 + * RVEC(3,J1,NTJ)*RVEC(3,J2,NTJ)*BOX(3)**2 + * (RVEC(1,J1,NTJ)*RVEC(2,J2,NTJ) + * RVEC(2,J1,NTJ)*RVEC(1,J2,NTJ)) *BOX(1)*BOX(2)*BOX(6) + * (RVEC(2,J1,NTJ)*RVEC(3,J2,NTJ) + * RVEC(3,J1,NTJ)*RVEC(2,J2,NTJ)) *BOX(2)*BOX(3)*BOX(4) + * (RVEC(3,J1,NTJ)*RVEC(1,J2,NTJ) + * RVEC(1,J1,NTJ)*RVEC(3,J2,NTJ)) *BOX(3)*BOX(1)*BOX(5) COSTHT = W / (DB1 * DB2) 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=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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,TDUMP,PDUMP, * STEMP,VSTEMP,PREST(3,3),SPRES(6),PPXYZ(7), * FJMOL, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY 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, * 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 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 (11X,'<<< 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',75('-'),'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 (4X, 121A1) 4011 FORMAT (4X,12('I',9('-')),'I') 4012 FORMAT (3X,4(I3,27X),I3) 4020 FORMAT ('I ',2(4X,'<',A2,'-',A2,'-',A2,'=',F6.2,'+-',F5.2, * '(N=',I5,')'),' I') 4025 FORMAT ('I ',2(4X,'<',A2,'-',A2,'-',A2,'=',F6.2,'+-',F5.2, * '(N=',I5,')'),' I'/ * 'I ',2(4X,'<',A2,'-',A2,'-',A2,'=',F6.2,'+-',F5.2, * '(N=',I5,')'),' I'/ * 'I ',1(4X,'<',A2,'-',A2,'-',A2,'=',F6.2,'+-',F5.2, * '(N=',I5,')'),36X,' I' ) 4021 FORMAT (4X,'I <',A2,'-',A2,'-',A2,' =',F7.2,'+-',F6.2,' (N=', * I7,')',78X,'I') END C C C ======== C================================================================ NETWRK SUBROUTINE NETWRK (NNN, IPR) PARAMETER (LNI=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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,TDUMP,PDUMP, * STEMP,VSTEMP,PREST(3,3),SPRES(6),PPXYZ(7), * FJMOL, NTSTEP REAL *8 DTIME,TEMP,DELTMP,TMPGET,TINT,TPRE,TDUMP,PDUMP, * STEMP,VSTEMP,PREST,SPRES,PPXYZ,FJMOL COMMON /ABOXOF/ BOX(6),VBOX(6),VOL, RCUT(2), * VIRM(6),DENSTY, NFORML,NRCUT(2),MXCUT REAL *8 BOX, VBOX, VOL, RCUT, VIRM,DENSTY 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, * 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 COMMON /WORK01/ DONB(6,LNI) COMMON /WORK02/ IONB(6,LNI) C INTEGER *4 NTET(19),ITREE(19),MING(9),MEMBER(9), * LING(9,LRG),MRING(LRG),ITET(6,19) C LMBR = 8 LCOL = LMBR * 2 + 1 IF (IPR.EQ.1) GO TO 901 C WRITE (*,1111) C1111 FORMAT (11X,'<<<<< 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 NR = 0 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 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.999000) 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 (11X,'<<<<< 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=11999,LTB=2004, LEL=8, LEM=10, LCT=2000000, * LSR=1254, LEE=LEL*(LEL+1)/2, L50=LCT/50+1, * LAA= 512, LNV=9876, LEF=LEM*(LEM+1)/2, LST=32, * LAT=LAA*4,LVA=24+LEM*2, L3P=7, LRG=LNI*3 ) 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 100 IF (FLNAME(3).EQ.'NDP-FORTRAN386' .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.'HP-9000 ') CALL HP9000 * (IYEAR,IMONTH,IDAY, * IHOUR,IMINUT,ISECND,I100TH) IF (FLNAME(3).EQ.'DN10000 ') CALL DN1000 * (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.'NEWS-F77 ') CALL NDP386 * (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.'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 c CALL GETDAT (IYEAR,IMONTH,IDAY) c CALL GETTIM (IHOUR,IMINUT,ISECND,I100TH) c 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================================================================= 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 character Adtval(3)*12 integer Idtval(8) c c Call DATE_AND_TIME(Adtval(1),Adtval(2),Adtval(3),Idtval) c IYEAR = Idtval(1) - 1900 ! now cut the centuries c IMONTH = Idtval(2) c IDAY = Idtval(3) c IHOUR = Idtval(5) c IMINUT = Idtval(6) c ISECND = Idtval(7) c I100TH = Idtval(8) 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 CHARACTER *8 ATIME CHARACTER *9 ADATE CHARACTER *3 BDATE(3), B2 EQUIVALENCE (ADATE,BDATE(1)) CHARACTER *1 CH INUM(CH) = ICHAR(CH) - 48 C C CALL TIME (ATIME) C CALL DATE (ADATE) C IHOUR = INUM(ATIME(1:1))*10 + INUM(ATIME(2:2)) IMINUT = INUM(ATIME(4:4))*10 + INUM(ATIME(5:5)) ISECND = INUM(ATIME(7:7))*10 + INUM(ATIME(8:8)) IYEAR = INUM(ADATE(8:8))*10 + INUM(ADATE(9:9)) 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============================================================ 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 jtime = 0 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 = mod(IYEAR + 92, 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 iyear = 0 imonth = 0 iday = 0 C CALL TIME (ATIME) C CALL IDATE ( IMONTH, IDAY, IYEAR) C IHOUR = ICHAR(ATIME(1:1))*10 + ICHAR(ATIME(2:2)) -528 IMINUT = ICHAR(ATIME(4:4))*10 + ICHAR(ATIME(5:5)) -528 ISECND = ICHAR(ATIME(7:7))*10 + ICHAR(ATIME(8:8)) -528 I100TH = 0 iyear = mod(iyear,100) RETURN END C C C ========== C============================================================== DN-10000 C ftn in AEGIS operating system SUBROUTINE DN1000 (IYEAR, IMONTH, IDAY, * IHOUR, IMINUT, ISECND, I100TH) C%INCLUDE '//dn10020/sys/ins/base.ins.ftn' C%INCLUDE '//dn10020/sys/ins/time.ins.ftn' C%INCLUDE '//dn10020/sys/ins/cal.ins.ftn' C INTEGER *4 IYEAR,IMONTH,IDAY, IHOUR,IMINUT,ISECND,I100TH C C INTEGER *2 time_clock(3),c_clock(6) c INTEGER *2 JYEAR,JMONTH,JDAY,JHOUR,JMINUT,JSECND,JMSE C EQUIVALENCE (c_clock(1),JYEAR), C * (c_clock(2),JMONTH), C * (c_clock(3),JDAY), C * (c_clock(4),JHOUR), C * (c_clock(5),JMINUT), C * (c_clock(6),JSECND) C JHOUR = 0 JMINUT = 0 JSECND = 0 JYEAR = 0 JMONTH = 0 JDAY = 0 C C CALL CAL_$GET_LOCAL_TIME(time_clock) C CALL CAL_$DECODE_TIME(time_clock,c_clock) IHOUR = JHOUR IMINUT = JMINUT ISECND = JSECND I100th = 0 C C CALL CAL_$GET_LOCAL_TIME(time_clock) C CALL CAL_$DECODE_TIME(time_clock,c_clock) IYEAR = JYEAR - JYEAR/100*100 IMONTH = JMONTH IDAY = JDAY 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 iyear = 0 imonth = 0 iday = 0 ihour = 0 iminut = 0 isecnd = 0 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) I100TH = 0 C IYEAR = (ICHAR(BDATE(1))-240)*10 + (ICHAR(BDATE(2))-240) 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 iyear = 0 imonth = 0 iday = 0 ihour = 0 iminut = 0 isecnd = 0 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)) 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)) 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 CHARACTER *1 CH CHARACTER DAT*8, TIM*10, ZONE*5 INTEGER IVV(8) INUM(CH) = IACHAR(CH) - 48 C iyear = 0 imonth = 0 iday = 0 ihour = 0 iminut = 0 isecnd = 0 c CALL DATE_AND_TIME (DAT,TIM,ZONE,IVV) C IHOUR = INUM(TIM(1:1))*10 + INUM(TIM(2:2)) IMINUT = INUM(TIM(3:3))*10 + INUM(TIM(4:4)) ISECND = INUM(TIM(5:5))*10 + INUM(TIM(6:6)) IYEAR = INUM(DAT(3:3))*10 + INUM(DAT(4:4)) iyear = mod(iyear,100) IMONTH = INUM(DAT(5:5))*10 + INUM(DAT(6:6)) IDAY = INUM(DAT(7:7))*10 + INUM(DAT(8:8)) I100TH = 0 RETURN END C C C================================================================== G77 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) 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