module assig integer eseign(0:2,0:20,-20:20),ipoint integer aseign(0:2,0:20,0:1,0:20),ipoint1 end module assig PROGRAM ROTFIT c my insertion USE MSFLIB USE MSIMSL c also it is necessary to change name of the array from deriv to deriv1 c in order to avoid redeclaration (deriv is declared in MSFLIB) IMPLICIT REAL*8 ( A-H,O-Z ) * PROGRAM ROTFIT (INPUT,OUTPUT,TAPE31,TAPE32,TAPE33,TAPE34,TAPE35, * 1 TAPE36,TAPE5=INPUT,TAPE6=OUTPUT) C******************************************************************* C I.KLEINER AND M.GODEFROID (FREE UNIVERSITY OF BRUSSELS, C 50, AV. F-D. ROOSEVELT, 1050 BRUSSELS, BELGIUM, 1987-91) ********************************************************************* C 20 aout 1992 C C THIS PROGRAM IS A LEAST-SQUARES PROCEDURE ABLE TO FIT C DATA FROM A MOLECULE WITH TORSION MOOVING.IT IS BASED C ON THE LEAST-SQUARES PROGRAM WRITTEN BY M.GODEFROID C "RTFIT" AND ON THE ROTATOR-TORSION PROGRAM"ROTTOR". C THE V MATRIX ELEMENTS ARE CALCULATED AS THE DERIVATIVES C OF THE ENERGY TO THE PARAMETER TO BE FITTED C THIS VERSION CAN TRAIT MICROWVE OR INFRARED DATA C THIS VERSION IS THE COPY OF TORFIT BUT WAS MODIFIED IN C ORDER TO RUN IN THE CDC NBS COMPUTER AND IS A WEIGHT LEAST-SQUARES C THIS PROGRAM INCLUDES V9 TERM,DABJ*J*(J+1),DABK*K**2,RHOJ AND C RHOK C FITV9B CAN TRAIT HIGH J VALUES THANKS A SPECIAL PROCEDURE OF C PICKING UP EIGENVALUES THAT INVOLVES A SUM OF THE SQUARE OF C COEFFIECIENTS C(K) ET C(-K) (SEE FUNCTION IPOSA AND IPOSE) C IN THIS VERSION ONLY THE WEIGHTS OF THE MW HAS CHANGED C (EACH MW LINE CAN RECEIVE A DIFFERENT WEIGHT). C IN THIS VERSION THE OUTPUT HAS CHANGED (SEE LINECAL) C NEW TERMS HAVE BEEN ADDED:DC1J,C2J,AK2J,GVJ,AMV,ANV,BK2 C C DAC,DBC,C4,ODELTA,AK3J,AK3K C RHO HAS BEEN REPLACED BY RHORHO AND IS ONLY FITTED FOR HTORS. C FITWGT9 IS A VERSION WHERE THE DIAGONAL MATRIX ELEMENTS IN K C AND OFF-DIAG. IN VT HAVE BEEN ADDED,CONTRARLY TO HERBST. C NEW PARAMETER IN FITWG10:D DELTA C FTJON10:D JON HAS MODIFIED THE PROGRAM... C AND I HAVE ADD AK1J,AK1K,AK2K,AK5K C FASTFIT:VERSION THAT HAS BEEN MODIFIED IN ORDER TO GAIN TIME C (SEE SUBROUTINES SETUP AND VSET). C THE ENERGIES AND EIGENVECTORS ARE CALCULATED AT THE VERY BEGINNI C OF EACH CYCLE FOR J=0 TO 14 FOR EVERY K AND VT STATES AND THEN C THOSE ENERGIES AND EIGENVECTORS ARE STORED IN 2 BIG MATRICES C (DERIV AND ENER) C THIS IS THE LAST (IMPROVED) VERSION OF GIROU (CIRCE):IKSRC18 C FOR VT=2+IPOSE,IPOSA MODIFIED (IKSRC20) C belgi28: changes by Ortigoso, AOUT 1992 C belgi30 : changes june 1993; the IPOSA has now a parity calc C form (23)* operator and the basis set has been extended from 7 to 9 C CAN TREAT UP TP VT=4 C belgi32 : has deltab and odeltb C belgi32b : has c4J,C4K,C1K,C2K and C12 C belgi37 : trying to rotate the eigenvectors to fix the labellingstuff C belgi38 ;labelling scheme for vt=0,1,2 same as in belgi32c C but for vt=3 call WIGNER and energy surface results C PERFORMS DIAGONALISATION(CRAY SUBROUTINES) C belgi42.f : DACJ,DBCJ,ODABJ,RHOB,RHOC c c 23 sep 99 JTH has made some minor changes. See cjth lines. IBLK is c no longer necessary in the input file. C************************************************************************ CHARACTER ABC*702 CHARACTER*6 PARA,REF CHARACTER*1 PR,PROBS,PRINF,PRSUP PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1) COMMON/EIGEN/H(NDMX,NDMX),WORK(NDMX),EGVC3(KDMX,9),NBR(2) COMMON/EIGEN1/EGVL(2*NDMX),EGVC(NDMX,2*NDMX) COMMON/TOR/A(9,NTORMX,2*KDMX),ETOR(2*KDMX,9) COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRON1 , * IBGTME,IBGVTD ,EVIB(2),IRMW,TERM COMMON/ROTOR/NROTOR,NDIMTO COMMON/PAR/IND(2,80),NP(2),X(160),ITO COMMON/BIG2/DERIV1(10,961,80),ENER(10,961) COMMON/EXPDAT / ETRANS(80000),IVOBS(2,80000), * NOBS(2,80000),KOBS(2,80000),IBLK(2,80000),IW(80000),W(80000), * NDATA,NADAT,EPSI,NOFIT,NFITMW,NFITIR,NFIMW0 ,NFIMW1 ,NITT, * IAST(80000),NFI004 ,NFI080 ,NFI100 ,NFI020 ,NFI200 ,NFI045 , & NGST0 ,NFI010 ,SW070,NFI070 ,NFIMW2,IKAKC,JMAX,NFI1M0, & NFIR10,NFIR21,NFIR32,NFIMW3,NFIMW4,SWA,SWE,NFITMWA,NFITMWE COMMON/CNTL/NIT,IEND,DELTAS,S,TME(80000),TERMST,NP12,SMW,SIR, 1 SMW0,SMW1,SIG004,SIG080,SIG10,SIG100,SIG020,SIG200,SIG045, & SGST0,SMW2,SIG1M0,SMW3,SIG32,SMW4 COMMON/SYMB/ABC COMMON/QUANT/ISIG,IV,N,KK COMMON/CHARA/PARA(2,160),PR,PROBS(2,80000),REF(80000) DIMENSION CST(2,117),VTLDV(160,160),VTLDTM (160),DELTAX (160) DIMENSION UNIT(160,160),V(160),V1(160),V2(160) DIMENSION WKSPCE(160),DELX(160),DELXST(160),IBLSTO(2) DIMENSION IPIV(160) INTEGER N, LDA, LWORK, IFAIL, INFO c my insertion integer*2 ihr, imin, isec, i100th DIMENSION UL(160,160),VR(160,160),SVD(160),COV(160,160) DIMENSION COR(160,160) c my insertion C C THIS PROGRAM MAY TRAIT (80000) OBSERVED DATA AND FIT (160) C PARAMETERS (UPPER AND/OR LOWER). C C CALL THE SUBROUTINE WHICH READ THE DATA' C C SEC=TCPU() C WRITE(6,*) ' BEGIN PROGRAM ',SEC c my insertion c open(unit=10,file='etype.txt',access='sequential',status='unknown') c open(unit=11,file='Atype.txt',access='sequential',status='unknown') WRITE(6,*) ' BEGIN PROGRAM ' c my insertion time CALL GETTIM (ihr, imin, isec, i100th) write(6,1012)ihr, imin, isec, i100th 1012 format(1x,'time',1x,i2,':',i2,':',i2,':',i2) c my insertion CALL DATA1(CST) C TERM= EVIB(2)-EVIB(1) TERMST=TERM C C BEGINNING OF THE FITTING PROCEDURE C NP12=NP(1)+NP(2) NPP=NP12 C PRINT*, 'NPP= ',NPP,' NP12= ',NP12 IF(ITO.NE.0) NPP=NP12+1 C C INITIALISATIONS C 23 NIT=1 SST=0. DO 30 I=1,NPP DELXST(I)=0.0 30 CONTINUE 25 DO 2 I=1,NPP V(I)=0.0 VTLDTM (I)=0.0 DO 3 J=1,NPP VTLDV(I,J)=0.0 3 CONTINUE 2 CONTINUE IBLSTO(1)=0.0 IBLSTO(2)=0.0 S=0.0 SMW=0.0 SWA=0.0 SWE=0. SIR=0.0 SIR10=0.0 SIR21=0.0 SIR32=0.0 SMW0=0.0 SMW1=0. SMW2=0. SMW3=0. SMW4=0. SIG004=0.0 SIG080=0.0 SIG010=0.0 SIG100=0.0 SIG020=0.0 SIG200=0.0 SIG045=0.0 SIG1M0=0.0 SGST0=0.0 SW070=0.0 NOFIT=0 NFITMW=0 NFITIR=0 NFIR10=0 NFIR21=0 NFIR32=0 NFIMW0 =0 NFIMW1 =0 NFIMW2=0 NFI004 =0 NFI080 =0 NFI010 =0 NFI100 =0 NFI020 =0 NFI200 =0 NFI045 =0 NFI1M0 =0 NGST0=0 NFI070 =0 NFIMW3=0 NFIMW4=0 NFITMWA=0 NFITMWE=0 IF(NP12.GT.(160)) THEN WRITE(6,*) 'TOO MANY PARAMETERS TO FIT' STOP ENDIF C C BEGINNING OF THE DO LOOP ON DATA,IF ONE DOESN'T WANT TO C FIT A DATA,IAST CAN'T BE EQUAL TO 1.NDATA IS THE TOTAL NUMBER C OF DATA INCLUDINGSIGMA=0 AND 1. C C SEC=TCPU() C WRITE(6,*) ' BEGIN DO 4 ',SEC WRITE(6,*) ' BEGIN DO 4 ' c my insertion time CALL GETTIM (ihr, imin, isec, i100th) write(6,1012)ihr, imin, isec, i100th c my insertion c my insertion c VTLDV - A matrix c VTLDTV - b vector c npp - number of parameters c K - index for measured transitions c I - index for fitted parameters c V(I) - derivative for given parameter c W(K) - weight of given measurement c CST(II,K) - old value c DELX(I) - variation of Ith parameter c XX - new value c DELTAX(I) - standard deviation c R - variation/standard deviation c RJTH - constant/standard deviation c my insertion C WE HAVE MODIFIED THE PROCEDURE HERE:DIN THE MATRIX DERIV, ONEA C IS CALCULATING THE ENERGIES AND DERIVATIVES FOR ALL THE J,K LEVELS C AT ONCE AND THEN ONE WILL PICK UP THE "GOOD" VALUES. CALL SETUP(CST) DO 4 K=1,NDATA IF (NOBS(1,K).GT.JMAX.OR.NOBS(2,K).GT.JMAX) GO TO 4 IF (IAST(K).EQ.0) GO TO 4 NOFIT=NOFIT+1 IF(IW(K).GE.1000) NFITMW=NFITMW+1 cjth added two cards here. isig=0 if(k.gt.nadat) isig=1 IF(IW(K).GE.1000.AND.ISIG.EQ.0) NFITMWA=NFITMWA+1 IF(IW(K).GE.1000.AND.ISIG.EQ.1) NFITMWE=NFITMWE+1 IF(IW(K).EQ.1.OR.IW(K).EQ.2.OR.IW(K).EQ.3) NFITIR=NFITIR+1 IF(IW(K).EQ.1) NFIR10=NFIR10+1 IF(IW(K).EQ.2) NFIR21=NFIR21+1 IF(IW(K).EQ.3) NFIR32=NFIR32+1 IF(IW(K).GE.1000.AND.IVOBS(1,K).EQ.0) NFIMW0 =NFIMW0 +1 IF(IW(K).GE.1000.AND.IVOBS(1,K).EQ.1) NFIMW1 =NFIMW1 +1 IF(IW(K).GE.1000.AND.IVOBS(1,K).EQ.3) NFIMW3 =NFIMW3 +1 IF(IW(K).GE.1000.AND.IVOBS(1,K).EQ.4) NFIMW4 =NFIMW4 +1 IF(IW(K).GE.1000.AND.IVOBS(1,K).EQ.2) NFIMW2=NFIMW2+1 C IF(IW(K).EQ.2000) NFITGD=NFITGD+1 IF(IW(K).EQ.10) NGST0=NGST0+1 IF(IW(K).EQ.1004.OR.IW(K).EQ.1005.OR.IW(K).EQ.1003) 1 NFI004 =NFI004 +1 IF(IW(K).EQ.1080) NFI080 =NFI080 +1 IF(IW(K).EQ.1010.OR.IW(K).EQ.1008) * NFI010 =NFI010 +1 IF(IW(K).EQ.1070) NFI070 =NFI070 +1 IF(IW(K).EQ.1100) NFI100 =NFI100 +1 IF(IW(K).EQ.1020) NFI020 =NFI020 +1 IF(IW(K).EQ.1200.OR.IW(K).EQ.1180.OR.IW(K).EQ.1160.OR. * IW(K).EQ.1150.OR.IW(K).EQ.1130) NFI200 =NFI200 +1 IF(IW(K).EQ.1030.OR.IW(K).EQ.1040.OR.IW(K).EQ.1050) * NFI045 =NFI045 +1 IF(IW(K).EQ.1990) NFI1M0 =NFI1M0 +1 cjth I need to get the derivatives, even if NITT=0, in order to generate a new cjth table similar to the one that Juan gave me. cjuan This command must be out to get Juan's table. IF(NITT.EQ.0) GO TO 4 C C SETUP THE MATRIX V,FOR CURRENT DATA DO 3000 I=1,NP12 V1(I)=0.0 V2(I)=0.0 3000 CONTINUE C C HERE WE ARE CALCULATING THE CORRECT INDICES IN ORDER TO FETCHA C THE ENERGIES AND DERIVATIVES CORRESPONDING TO THE OBSERVED TRANSIT C C II=1 C CALL VSET(II,V1,ELOWER,K,CST) C II=2 C CALL VSET(II,V2,EUPPER,K,CST) C DO 26 I=1,NP12 C PRINT*,' V1= ',V1(I),' V2= ',V2(I),' I= ',I DO 331 LO=1,2 N=NOBS(LO,K) KK=KOBS(LO,K) IV=IVOBS(LO,K) PR=PROBS(LO,K) IF(PR.EQ.'+') IPR=1 IF(PR.EQ.'-') IPR=0 IF(K.GT.NADAT) THEN ISIG=1 IVV=IV+6 INK=N**2+N+KK+1 ELSE ISIG=0 IVV=IV+1 INK=N**2+N+KK+1-IPR*N ENDIF IF(LO.EQ.1) THEN ELOWER=ENER(IVV,INK) ELSE EUPPER=ENER(IVV,INK) ENDIF DO 26 I=1,NP12 IF(LO.EQ.1) THEN V1(I)= DERIV1(IVV,INK,I) ELSE V2(I)=DERIV1(IVV,INK,I) ENDIF V(I)=V2(I)-V1(I) 26 CONTINUE 331 CONTINUE cjth Here I attempt to construct a derivative table for dehyperfining cjth similar to what Juan gave me. Be sure to comment out below cjuan's! itable=0 c itable=1 if(itable.eq.0) go to 332 if(nitt.ne.0) go to 332 ejuan = (eupper+term-elower)*29979.2458 write(6,1332) nobs(2,k),kobs(2,k),nobs(1,k),kobs(1,k), 1 ejuan,v2(1),v2(2),v2(3),v2(4),(v1(i),i=1,4) 1332 format(4i3,f15.2,8f9.4) 332 continue C C IF THE VIB.ENERGY HAS TO BE FIT,THE DIAG ELEMENT OF THE C V MATRIX WILL CONTAIN 1. C HERE,IT SEEMS TO BE AN ERROR ON THE PREVIOUS WAY OF CALCULATION! C IF(ITO.NE.0) THEN V(NPP)=1. C V(NPP)=0.0 C DO 8 I=1,NROTOR C V(NPP)=V(NPP)+EGVC(I,NBR(2))**2 C PRINT*,' V(NPP)= ',V(NPP) ENDIF C C SET UP THE VTILDE V MATRIX(NP*NP) C DO 10 I=1,NPP DO 810 J=1,NPP VTLDV(I,J)=VTLDV(I,J)+V(I)*V(J)*W(K) 810 CONTINUE 10 CONTINUE C C OBSERVED MINUS CALCULATED C TME(K)=ETRANS(K)-TERM-EUPPER +ELOWER C STANDARD DEVIATION FOR EACH LINE,WEIGHTED S=S+TME(K)**2*W(K) if(iw(K).GT.1000) then etrans2=etrans(K)*29979.2458 else etrans2=etrans(K) endif c print*,'s=',s,'etrans=',etrans2,'K=',k cjth added two if's here. IF(IW(K).GE.1000.and.k.le.nadat) then SWA=SWA+TME(K)**2*W(K) ELSEIF(IW(K).GE.1000.and.k.gt.nadat) then SWE=SWE+TME(K)**2*W(K) end if IF(IW(K).GE.1000) THEN SMW=SMW+TME(K)**2*W(K) IF(IVOBS(1,K).EQ.0.AND.IW(K).GE.1000) THEN SMW0=SMW0+TME(K)**2*W(K) ELSEIF(IVOBS(1,K).EQ.1.AND.IW(K).GE.1000) THEN SMW1=SMW1+TME(K)**2*W(K) ELSEIF(IVOBS(1,K).EQ.2.AND.IW(K).GE.1000) THEN SMW2=SMW2+TME(K)**2*W(K) ELSEIF(IVOBS(1,K).EQ.3.AND.IW(K).GE.1000) THEN SMW3=SMW3+TME(K)**2*W(K) ELSEIF(IVOBS(1,K).EQ.4.AND.IW(K).GE.1000) THEN SMW4=SMW4+TME(K)**2*W(K) ENDIF C ELSEIF (IW(K).EQ.2000) THEN C SWGOOD=SWGOOD+TME(K)**2*W(K) IF(IW(K).EQ.1004.OR.IW(K).EQ.1005.OR.IW(K).EQ.1003) THEN SIG004=SIG004+TME(K)**2*W(K) ELSEIF(IW(K).EQ.1080) THEN SIG080=SIG080+TME(K)**2*W(K) ELSEIF(IW(K).EQ.1010.OR.IW(K).EQ.1008) THEN SIG010=SIG010+TME(K)**2*W(K) ELSEIF(IW(K).EQ.1100) THEN SIG100=SIG100+TME(K)**2*W(K) ELSEIF(IW(K).EQ.1020) THEN SIG020=SIG020+TME(K)**2*W(K) ELSEIF(IW(K).EQ.1070) THEN SW070=SW070+TME(K)**2*W(K) ELSEIF(IW(K).EQ.1200.OR.IW(K).EQ.1180.OR.IW(K).EQ. 1 1160.OR.IW(K).EQ.1150.OR.IW(K).EQ.1130) THEN SIG200=SIG200+TME(K)**2*W(K) ELSEIF(IW(K).EQ.1030.OR.IW(K).EQ.1040.OR.IW(K).EQ. 1 1050) THEN SIG045=SIG045+TME(K)**2*W(K) ELSEIF(IW(K).EQ.1990) THEN SIG1M0=SIG1M0+TME(K)**2*W(K) ENDIF ELSEIF(IW(K).EQ.1) THEN SIR10=SIR10+TME(K)**2*W(K) SIR=SIR+TME(K)**2*W(K) ELSEIF(IW(K).EQ.2) THEN SIR21=SIR21+TME(K)**2*W(K) SIR=SIR+TME(K)**2*W(K) ELSEIF(IW(K).EQ.3) THEN SIR32=SIR32+TME(K)**2*W(K) SIR=SIR+TME(K)**2*W(K) ELSEIF(IW(K).EQ.10) THEN SGST0=SGST0+TME(K)**2*W(K) ENDIF C IF(IW(K).GE.1000) TME(K)=TME(K)*29979.2458 IF(IBGTME.EQ.1) WRITE(6,300) K,TME(K),EUPPER,ELOWER,S 300 FORMAT(' K= ',I5,2X,' TME= ',F17.9,2X,' EUPPER= ',F16.8, 1 2X,' ELOWER= ',F16.8,' S= ',F20.8) DO 11 I=1,NPP VTLDTM (I)=VTLDTM (I)+V(I)*TME(K)*W(K) 11 CONTINUE C C END OF THE LOOP ON DATA C 4 CONTINUE C SEC=TCPU() C WRITE(6,*) ' END DO 4 ',SEC WRITE(6,*) ' END DO 4 ' c my insertion time CALL GETTIM (ihr, imin, isec, i100th) write(6,1012)ihr, imin, isec, i100th c my insertion IF(NITT.EQ.0) GO TO 244 PRINT*,'S(BEFORE FITTING)= ',S S=SQRT(S/(NOFIT-NPP)) IF(NFITMW.EQ.0) THEN SMW=0.0 ELSE SMW=SQRT(SMW/NFITMW) ENDIF IF(NFITMWA.EQ.0) THEN SWA=0.0 ELSE SWA=SQRT(SWA/NFITMWA) ENDIF IF(NFITMWE.EQ.0) THEN SWE=0.0 ELSE SWE=SQRT(SWE/NFITMWE) ENDIF IF (NFITIR.EQ.0) THEN SIR=0.0 ELSE SIR=SQRT(SIR/NFITIR) ENDIF IF (NFIR10.EQ.0) THEN SIR10=0.0 ELSE SIR10=SQRT(SIR10/NFIR10) ENDIF IF (NFIR21.EQ.0) THEN SIR21=0.0 ELSE SIR21=SQRT(SIR21/NFIR21) ENDIF IF (NFIR32.EQ.0) THEN SIR32=0.0 ELSE SIR32=SQRT(SIR32/NFIR32) ENDIF IF(NFIMW0 .EQ.0) THEN SMW0=0. ELSE SMW0=SQRT(SMW0/NFIMW0 ) ENDIF IF(NFIMW1 .EQ.0) THEN SMW1=0.0 ELSE SMW1=SQRT(SMW1/NFIMW1 ) ENDIF IF(NFIMW2.EQ.0) THEN SMW2=0. ELSE SMW2=SQRT(SMW2/NFIMW2) ENDIF IF(NFIMW3.EQ.0) THEN SMW3=0. ELSE SMW3=SQRT(SMW3/NFIMW3) ENDIF IF(NFIMW4.EQ.0) THEN SMW4=0. ELSE SMW4=SQRT(SMW4/NFIMW4) ENDIF IF(NFI004 .EQ.0) THEN SIG004=0. ELSE SIG004=SQRT(SIG004/NFI004 ) ENDIF IF(NFI070 .EQ.0) THEN SW070=0.0 ELSE SW070=SQRT(SW070/NFI070 ) ENDIF IF(NFI080 .EQ.0) THEN SIG080=0.0 ELSE SIG080=SQRT(SIG080/NFI080 ) ENDIF IF(NFI010 .EQ.0) THEN SIG010=0.0 ELSE SIG010=SQRT(SIG010/NFI010 ) ENDIF IF(NFI100 .EQ.0) THEN SIG100=0.0 ELSE SIG100=SQRT(SIG100/NFI100 ) ENDIF IF(NFI020 .EQ.0) THEN SIG020=0.0 ELSE SIG020=SQRT(SIG020/NFI020 ) ENDIF IF(NFI200 .EQ.0) THEN SIG200=0.0 ELSE SIG200=SQRT(SIG200/NFI200 ) ENDIF IF(NFI045 .EQ.0) THEN SIG045=0.0 ELSE SIG045=SQRT(SIG045/NFI045 ) ENDIF IF(NFI1M0 .EQ.0) THEN SIG1M0=0.0 ELSE SIG1M0=SQRT(SIG1M0/NFI1M0 ) ENDIF IF(NGST0.EQ.0) THEN SGST0=0. ELSE SGST0=SQRT(SGST0/NGST0) ENDIF PRINT*,' S= ',S,' NOFIT= ',NOFIT,'NPP= ',NPP,' SMW= ',SMW, & ' SIR= ',SIR,' NFITMW= ',NFITMW,' NFITIR= ',NFITIR,NFIMW1 , & ' SMW0= ',SMW0,' SMW1= ',SMW1,' NFITMW0= ',NFIMW0 , & ' NFITMW1= ',NFIMW1 ,' SIG004= ',SIG004,' NFIT004= ', & NFI004 ,' SIG080= ',SIG080,' NFIT080= ',NFI080 , & ' SIG010= ',SIG010,' NFIT010= ',NFI010 ,' SIG100= ',SIG100, & ' NFIT100= ',NFI100 ,' SIG020= ',SIG020,' NFIT020= ', & NFI020 ,' SIG200= ',SIG200,' NFIT200= ',NFI200 , & ' SIG045= ',SIG045,' NFIT045= ',NFI045 ,' SGST0= ',SGST0, & ' NGST0= ',NGST0,' SW070= ',SW070,' NFIT070= ',NFI070, & ' SMW2= ',SMW2,' NFIMW2= ',NFIMW2,' SIG1M0= ',SIG1M0, & ' NFIT1M0= ',NFI1M0,' SIG10= ',SIR10,' NFIT10= ',NFIR10, & ' SIG21= ',SIR21,' NFIT21= ',NFIR21,' SMW3= ',SMW3, & ' NFIMW3= ',NFIMW3,' SIR32= ',SIR32,' NFIR32=',NFIR32, & ' SMW4= ',SMW4,' NFIMW4= ', NFIMW4, & ' SMWA=',SWA,' NFITMWA=',NFITMWA,' SWME=',SWE, & ' NFITMWE=',NFITMWE WRITE(6,901) NOFIT 901 FORMAT(/,' NUMBER OF DATA INCLUDED IN THE FIT= ',I6) IF(IBGVTD .NE.0) THEN WRITE(6,51) CALL MATOUT(VTLDV,160,160,NPP,NPP) ENDIF 51 FORMAT(/,' VTLDV MATRIX BEFORE INVERSION',/) C C SET UP THE VTLDV MATRIX WITH ONE ON THE DIAGONAL. C DELX IS THE SQUARE ROOT OF THE DIAGONAL C DO 12 I=1,NPP DELX(I)= SQRT(VTLDV(I,I)) 12 CONTINUE DO 13 I=1,NPP DO 14 J=1,NPP VTLDV(I,J)=VTLDV(I,J)/(DELX(I)*DELX(J)) 14 CONTINUE 13 CONTINUE IF(IBGVTD .NE.0) THEN WRITE(6,51) CALL MATOUT(VTLDV,160,160,NPP,NPP) ENDIF c my insertion c singular value decomposition of the VTLDV IPATH=1 TOL=1.D-50 svd=0. vr=0. ul=0. call DLSVRR(NPP,NPP,VTLDV,160,IPATH,TOL,IRANK,SVD,UL,160,VR,160) write(6,*)'rank of the matrix',irank c my insertion C C INVERSION OF THE VTLDV MATRIX.FROM THIS POINT,VTLDV C BECOMES THE INVERSE MATRIX C cjth The next 8 lines or so needed fixing to run on the amur. c CALL F01AAF(VTLDV,160,NPP,UNIT,160,WKSPCE,IFAIL) c my insertion call DLINRG(NPP,VTLDV,160,VTLDV,160) c CALL F07ADF(NPP,NPP,VTLDV,160,IPIV,INFO) c CALL F07AJF(NPP,VTLDV,160,IPIV,WKSPCE,160,IFAIL) do 144 i=1,npp do 145 j=1,npp UNIT(i,j)=VTLDV(i,j) 145 continue 144 continue C CALL SGETRI(NPP,UNIT,160,WKSPCE,IFAIL) PRINT*,' IFAIL= ',IFAIL IF(IBGVTD .NE.0) THEN PRINT*,' UNIT AFTER INVERSION...' CALL MATOUT(UNIT,160,160,NPP,NPP) ENDIF DO 18 I=1,NPP DO 19 J=1,NPP VTLDV(I,J)=UNIT(I,J)/(DELX(I)*DELX(J)) 19 CONTINUE 18 CONTINUE IF(IBGVTD .NE.0) THEN PRINT*,' VTLDV AFTER INVERSION' CALL MATOUT(VTLDV,160,160,NPP,NPP) ENDIF C C FROM THIS POINT,DELX BECOMES THE VARIATION OF C THE PARAMETERS C DO 21 I=1,NPP DELX(I)=0.0 DO 800 K=1,NPP DELX(I)= VTLDV(I,K)*VTLDTM (K)+DELX(I) 800 CONTINUE 21 CONTINUE ACC=1. WRITE(6,*) 'ACC= ',ACC WRITE(6,302) C ***** Format changes by JTH 302 FORMAT(/,'STATE',2X,'CONSTANT',4X,'OLD VALUE',13X, 1 'VARIATION',13X,'NEW VALUE',13X,'STD.DEV.',12X,'VARIA/STV', 2 5X,'CONST/STV') DO 20 I=1,NPP DELTAX (I)=SQRT(VTLDV(I,I))*S IF(I.LE.NP12) THEN IF(I.GT.NP(1)) THEN II=2 J=I-NP(1) ELSE II=1 J=I ENDIF K=IND(II,J) XX=CST(II,K)+DELX(I)*ACC R= DELX(I)/DELTAX (I) RJTH=XX/DELTAX(I) WRITE(6,301) II,ABC(6*(K-1)+1:6*K),CST(II,K),DELX(I), & XX,DELTAX (I),R,RJTH CST(II,K)=XX 301 FORMAT(I4,2X,A6,4F22.15,F14.7,E14.2) ELSE II=2 VIBEN=TERM+DELX(I)*ACC R= DELX(I)/DELTAX (I) WRITE(6,301) II,' TERM ',TERM,DELX(I),VIBEN,DELTAX (I),R TERM=VIBEN ENDIF DELXST(I)=DELX(I) 20 CONTINUE C******NEW MATERIAL BELOW DO 322 I=1,NPP IF(I.LE.NP12) THEN IF(I.GT.NP(1)) THEN II=2 J=I-NP(1) ELSE II=1 J=I ENDIF K=IND(II,J) WRITE(6,323) ABC(6*(K-1)+1:6*K),CST(II,K) 323 FORMAT(2X,A6,' = ',F24.17,',') ENDIF 322 CONTINUE C******NEWMATERIAL ABOVE WRITE(6,900) S 900 FORMAT(/,' STANDARD DEVIATION BEFORE= ',F20.6) DELTAS=S-SST SST=S CALL CNTRL(NPP,DELX,DELTAX ,CST) c my insertion time CALL GETTIM (ihr, imin, isec, i100th) write(6,1012)ihr, imin, isec, i100th if(iend.eq.0)then c output of singular values and sigular right vectors write(6,*)' singular values and singular right vectors' icc=npp/8 if(icc*8.eq.npp)icc=icc-1 do icn=0,icc nppp=8+8*icn if(8+8*icn.gt.npp)nppp=npp write(6,*) ' ' write(6,314)(svd(ivr),ivr=1+8*icn,nppp) write(6,*) ' ' do isv=1,npp write(6,314)(VR(isv,ivr),ivr=1+8*icn,nppp) enddo enddo 314 format(1x,8E10.3) c covariation matrix do isv=1,npp do ivr=1,isv cov(isv,ivr)=0. do ikr=1,npp cov(isv,ivr)=cov(isv,ivr)+VR(isv,ikr)*VR(ivr,ikr)/(SVD(ikr)**2) enddo enddo enddo c correlation matrix do isv=1,npp do ivr=1,isv cor(isv,ivr)=cov(isv,ivr)/dsqrt(dabs(cov(isv,isv)*cov(ivr,ivr))) enddo enddo c output of the correlation matrix write(6,*)' correlation matrix ' do icn=0,icc write(6,*) ' ' do isv=1+8*icn,npp c decoding of parameter name IF(Isv.LE.NP12) THEN IF(Isv.GT.NP(1)) THEN II=2 J=Isv-NP(1) ELSE II=1 J=Isv ENDIF Ksv=IND(II,J) endif c end of decoding nppp=8+8*icn if(8+8*icn.gt.isv)nppp=isv write(6,315)isv,ABC(6*(Ksv-1)+1:6*Ksv), 1 (cor(isv,ivr),ivr=1+8*icn,nppp) enddo write(6,316)(ivr,ivr=1+8*icn,nppp) enddo 315 format(1x,I3,1x,A6,1x,8F9.4) 316 format(12x,8(6x,I3)) endif c my insertion C C CALL CHEKPTX(IFILES,1) C IF(IEND) 23,24,25 C24 SEC=TCPU() C WRITE(6,*) ' BEGIN SETUP LINECAL ',SEC 24 CALL SETUP(CST) C******THENEXT STATEMENT USED TO BE NUMBER 24. 244 CALL LINECA (CST,NPP) C SEC=TCPU() C WRITE(6,*) ' END LINECAL ',SEC WRITE(6,*) ' END LINECAL ' c my insertion time CALL GETTIM (ihr, imin, isec, i100th) write(6,1012)ihr, imin, isec, i100th c my insertion END C************************************************************** SUBROUTINE ASET(K,EGVL,EGVC,ETOR,A) IMPLICIT REAL*8 ( A-H,O-Z ) C************************************************************ C STORAGE OF THE COEFICIENTS OF THE TORSION EIGENVECTORS C CHARACTER ABC*702 CHARACTER*1 PR,PROBS CHARACTER*6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1) COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRON1 , * IBGTME,IBGVTD ,EVIB(2),IRMW,TERM COMMON/ROTOR/NROTOR,NDIMTO COMMON/QUANT/ISIG,IV,N,KK COMMON/CHARA/PARA(2,160),PR,PROBS(2,80000),REF(80000) DIMENSION EGVL(NDMX),EGVC(NDMX,NDMX),ETOR(KDMX,9) DIMENSION A(9,NTORMX,KDMX) IK=K+N+1 DO 1 I=1,(09) DO 2 J=1,NDIMTO A(I,J,IK)=EGVC(J,I) 2 CONTINUE ETOR(IK,I)=EGVL(I) C PRINT*,'ETOR=',ETOR(IK,I),'IK=',IK,'I=',I 1 CONTINUE IF(K.EQ.-N) GO TO 16 DO 3 I=1,(09) IF((A(I,10,IK)/A(I,10,IK-1)).LT.0.0) THEN DO 4 J=1,NDIMTO A(I,J,IK)=-A(I,J,IK) 4 CONTINUE ENDIF 3 CONTINUE 16 RETURN END C************************************************************ SUBROUTINE CNTRL(NPP,DELX,DELTAX ,CST) IMPLICIT REAL*8 ( A-H,O-Z ) C************************************************************ C MONITORS THE FITTING(CONCONVERGENCE,REJECTION OF TRANSITIONS, C DIVERGENCE) C CHARACTER*6 PARA,REF CHARACTER*1 PR,PROBS INTEGER REJ COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRON1 , * IBGTME,IBGVTD ,EVIB(2),IRMW,TERM COMMON/PAR/IND(2,80),NP(2),X(160),ITO COMMON/EXPDAT / ETRANS(80000),IVOBS(2,80000), * NOBS(2,80000),KOBS(2,80000),IBLK(2,80000),IW(80000),W(80000), * NDATA,NADAT,EPSI,NOFIT,NFITMW,NFITIR,NFIMW0 ,NFIMW1 ,NITT, * IAST(80000),NFI004 ,NFI080 ,NFI100 ,NFI020 ,NFI200 ,NFI045 , & NGST0 ,NFI010 ,SW070,NFI070 ,NFIMW2,IKAKC,JMAX,NFI1M0, & NFIR10,NFIR21,NFIR32,NFIMW3,NFIMW4,SWA,SWE,NFITMWA,NFITMWE COMMON/CNTL/NIT,IEND,DELTAS,S,TME(80000),TERMST,NP12,SMW,SIR, 1 SMW0,SMW1,SIG004,SIG080,SIG10,SIG100,SIG020,SIG200,SIG045, & SGST0,SMW2,SIG1M0,SMW3,SIG32,SMW4 COMMON/CHARA/PARA(2,160),PR,PROBS(2,80000),REF(80000) DIMENSION DELX(160),DELTAX (160),CST(2,117) C THE CONVERGENCE CRITERION HAS BEEN CHANGED (NOV.1990). CC I = 1 IF(NIT.EQ.1) THEN IEND=1 WRITE(6,307) NIT NIT=NIT+1 RETURN ENDIF IF(NIT.EQ.NITT) THEN IEND=0 C WRITE(6,'("FINISHED",I4," PRESET ITERATIONS")') NIT RETURN ENDIF RS=DELTAS/S DO 6 I=1,NPP RI=ABS(DELX(I))/DELTAX (I) IF(RI.GT.1.E-3) THEN IF(RS.GT.1.E-1) THEN CC6 IF (ABS(DELX(I)) .GE. DELTAXL(I)) THEN C IF (DELTAS .GT. 0 .AND. NIT .GE. 4) THEN c WRITE(6,*) ' PROGRAM IS DIVERGING ...' c IF(NITT.LE.8) GO TO 54 c STOP c54 CONTINUE END IF CC IF(NIT.GT.NITT) STOP IEND = 1 WRITE(6,307) NIT NIT = NIT + 1 RETURN END IF CC I = I + 1 CC IF (I .LE. NPP) GO TO 6 C 6 CONTINUE REJ = 0 C CALL REJEC(TME,S,REJ) IF (REJ .EQ. 0) THEN WRITE(6,*) ' PROGRAM HAS CONVERGED AFTER ',NIT, 1 ' ITERATIONS' IEND = 0 RETURN ELSE DO 94 I = 1,NP12 IF (I .GT. NP(1)) THEN II = 2 J = I - NP(1) ELSE II = 1 J = I END IF CST(II,IND(II,J)) = X(I) 94 CONTINUE TERM = TERMST IEND = -1 WRITE(6,807) RETURN END IF 307 FORMAT(/,' *** END OF CYCLE NO. ',I3,' *** ') 807 FORMAT(//,' *** NEW LEAST SQUARE FITTING PROCEDURE ***', 1 /,' ==========================================') END SUBROUTINE DATA1(CST) use assig IMPLICIT REAL*8 ( A-H,O-Z ) C********************************************************** C THIS SUBROUTINE READS THE EXPERIMENTAL VALUES AND CALLS 2 C SUBROUTINES:DDATA11 WHICH READS THE VALUES OF THE CONSTANTS C AND PARAM WHICH READS WHICH PARAMETERS MUST BE FITTED C*********************************************************** C READ THE CONSTANT VALUES AND DECIDE WHICH PARAMETERS TO FIT C I=1 LOWER STATE;I=2 UPPER STATE C CHARACTER ABC*702 CHARACTER*1 PR,PROBS,PRINF,PRSUP CHARACTER*6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1) COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRON1 , * IBGTME,IBGVTD ,EVIB(2),IRMW,TERM COMMON/PAR/IND(2,80),NP(2),X(160),ITO COMMON/EXPDAT / ETRANS(80000),IVOBS(2,80000), * NOBS(2,80000),KOBS(2,80000),IBLK(2,80000),IW(80000),W(80000), * NDATA,NADAT,EPSI,NOFIT,NFITMW,NFITIR,NFIMW0 ,NFIMW1 ,NITT, * IAST(80000),NFI004 ,NFI080 ,NFI100 ,NFI020 ,NFI200 ,NFI045 & ,NGST0 ,NFI010 ,SW070,NFI070 ,NFIMW2,IKAKC,JMAX,NFI1M0, & NFIR10,NFIR21,NFIR32,NFIMW3,NFIMW4,SWA,SWE,NFITMWA,NFITMWE COMMON/SYMB/ABC COMMON/CHARA/PARA(2,160),PR,PROBS(2,80000),REF(80000) DIMENSION CST(2,117) c my insertion open(unit=5,file='input.txt',access='sequential',status='old') c the following cards are for Ilyushyn label scheme c my insertion c open(unit=22,file='Evt01.dat',access='sequential',status='old') c iklflag=0 c ikl=0 c do while (iklflag.ne.1) c ikl=ikl+1 c read(22,*,end=1001)ivt1,j1,kkk1,neig1 c eseign(ivt1,j1,kkk1)=neig1 c cycle c1001 iklflag=1 c exit c enddo c ipoint=ikl-1 c close(22) c open(unit=23,file='Avt01.dat',access='sequential',status='old') c iklflag=0 c ikl=0 c do while (iklflag.ne.1) c ikl=ikl+1 c read(23,*,end=1002)ivt1,j1,kkk1,ipar1,neig1 c if(ipar1.eq.2)then c aseign(ivt1,j1,0,kkk1)=neig1 c else c aseign(ivt1,j1,1,kkk1)=neig1 c endif c cycle c1002 iklflag=1 c exit c enddo c ipoint1=ikl-1 c close(23) WRITE(6,*) ' THIS OUTPUT IS FROM BELGI38 ' READ(5,*) EPSI,IBUG1,IBUG2,IBUG3,IBGTME,IBGVTD ,IBUG4 WRITE(6,*) ' EPSI= ',EPSI,' IBUG1= ',IBUG1,' IBUG2= ', * IBUG2,' IBUG3= ',IBUG3,' IBGTME= ',IBGTME,' IBGVTDV= ', * IBGVTD ,'IBUG4= ',IBUG4 READ(5,20) KTRONC READ(5,20) IRMW 20 FORMAT(I3) WRITE(6,21)KTRONC,IRMW 21 FORMAT(' KTRONC = ',I3,' IRMW= ',I3) IF(KTRONC.GT.(10)) THEN WRITE(6,*) ' DIMENSION KTRONC TOO LOW ' STOP ENDIF C THE NEXT CARD WAS ADDED FOR NBS COMPUTER. EVIB(1)=0. EVIB(2)=0. IF(IRMW.EQ.1) THEN DO 2 I=1,1 CALL DATA11(I,CST) READ (5,*) EVIB(I) CALL PARAM(I,CST) C PRINT*,' NP APRES PARAM= ',NP(I) 2 CONTINUE ELSEIF(IRMW.EQ.2) THEN DO 3 I=1,2 CALL DATA11(I,CST) C PRINT*, 'I= ',I,' IRMW= ',IRMW READ (5,*) EVIB(I) WRITE(6,*) ' EVIB= ',EVIB(I),'I= ',I PRINT*,' EVIB(1)= ',EVIB(1),' EVIB(2)= ',EVIB(2) CALL PARAM(I,CST) C PRINT*,' NP APRES PARAM= ',NP(I) 3 CONTINUE ENDIF READ(5,*) ITO,NITT,IKAKC,JMAX WRITE(6,*) ' VIB.ENERGY TO BE FITTED? ITO= ',ITO WRITE(6,*)' NUMBER OF ITERATIONS= ',NITT WRITE(6,*)' MAXIMUM VALUE OF J= ',JMAX C I=1 C C IBLK:DNUMBER OF THE N BLOCK;NBR:DPLACE IN THIS BLOCK C 1 IF(IRMW.EQ.1) THEN cjth I have changed these reads to follow des conventions internationales! c READ(5,23,END=10) ETRANS(I),IVOBS(1,I),NOBS(1,I), READ(5,23,END=10) ETRANS(I),IVOBS(2,I),NOBS(2,I), c A KOBS(1,I),PROBS(1,I),IBLK(1,I),IVOBS(2,I),NOBS(2,I), A KOBS(2,I),PROBS(2,I),IBLK(2,I),IVOBS(1,I),NOBS(1,I), c B KOBS(2,I),PROBS(2,I),IBLK(2,I),IAST(I),IW(I),REF(I) B KOBS(1,I),PROBS(1,I),IBLK(1,I),IAST(I),IW(I),REF(I) cjuan This command must be in to generate Juan's table. c iast(i)=1 C cjth I have added the following card in several places to eliminate vt=1. c if(ivobs(1,i).eq.1.and.ivobs(2,i).eq.1) go to 1 cjth I added these cards to make it unnecessary to input the IBLK values. c IBLK are not necessary anymore! iblk(1,I)=nobs(1,I)+1 iblk(2,I)=nobs(2,I)+1 c IJK debug 9 octobre 2006, change of sign of Pg-rho.Pa if(probs(1,I).eq.' ') then KOBS(1,I)=-KOBS(1,I) KOBS(2,I)=-KOBS(2,I) endif c cjth I added these cards to calculate an entire vt=1 spectrum c They must be taken out immediately after the calculation!!!!!! c ivobs(1,I) = 1 c ivobs(2,I) = 1 c IF(ETRANS(I).EQ.10000.OR.ETRANS(I).EQ.10000.000) THEN REF(I)=' ' ENDIF c write(6,23) ETRANS(I),IVOBS(1,I),NOBS(1,I), c A KOBS(1,I),PROBS(1,I),IBLK(1,I),IVOBS(2,I),NOBS(2,I), c B KOBS(2,I),PROBS(2,I),IBLK(2,I),IAST(I),IW(I),REF(I) c those lines are only for CH3COOH! cjth I have turned off this vt=1 quantum number exchange (which were used c for acetic acid)! IF(IVOBS(1,I).EQ.9.AND.IAST(I).EQ.1) THEN c IF(IVOBS(1,I).EQ.1.AND.IAST(I).EQ.1) THEN NSUP=NOBS(2,I) NINF=NOBS(1,I) KSUP=KOBS(2,I) KINF=KOBS(1,I) PRSUP=PROBS(2,I) PRINF=PROBS(1,I) NOBS(2,I)=NINF NOBS(1,I)=NSUP KOBS(2,I)=KINF KOBS(1,I)=KSUP PROBS(2,I)=PRINF PROBS(1,I)=PRSUP ENDIF c IF(IVOBS(1,I).EQ.1.AND.NOBS(1,I).GT.17) IAST(I)=0 c cjth***THE NEXT WRITE IS USEFUL FOR DEBUGGING TYPOS IN THE DATA FILE. JTH c WRITE(6,24) ETRANS(I),IVOBS(1,I),NOBS(1,I),KOBS(1,I) c A ,PROBS(1,I),IBLK(1,I),IVOBS(2,I),NOBS(2,I),KOBS(2,I) c B ,PROBS(2,I),IBLK(2,I),IAST(I),I,IW(I),REF(I) C THE WEIGHT (W) IS EQUAL TO THE INVERSE OF THE SQUARE OF C EXPERIMENTAL UNCERTAINTY IF(IW(I).EQ.1005) THEN ETRANS(I)=ETRANS(I)/29979.2458 W(I)=3.59502E+13 ELSEIF(IW(I).EQ.1000) THEN ETRANS(I)=ETRANS(I)/29979.2458 W(I)=8.98755E+12 ELSEIF(IW(I).EQ.1010) THEN ETRANS(I)=ETRANS(I)/29979.2458 W(I)=8.98755E+12 ELSEIF(IW(I).EQ.1040) THEN ETRANS(I)=ETRANS(I)/29979.2458 W(I)=5.61722E+11 ELSEIF(IW(I).EQ.1004) THEN ETRANS(I)=ETRANS(I)/29979.2458 W(I)=5.61722E+13 ELSEIF(IW(I).EQ.1003) THEN ETRANS(I)=ETRANS(I)/29979.2458 W(I)=9.986168E+13 ELSEIF(IW(I).EQ.1020) THEN ETRANS(I)=ETRANS(I)/29979.2458 W (I)=2.24688E+12 ELSEIF(IW(I).EQ.1050) THEN ETRANS(I)=ETRANS(I)/29979.2458 W(I)=3.59502E+11 ELSEIF(IW(I).EQ.1030) THEN ETRANS(I)=ETRANS(I)/29979.2458 W(I)=9.98617E+11 ELSEIF(IW(I).EQ.1008) THEN ETRANS(I)=ETRANS(I)/29979.2458 W(I)=1.4043E+13 ELSEIF(IW(I).EQ.1100) THEN ETRANS(I)=ETRANS(I)/29979.2458 W(I)=8.98755E+10 ELSEIF(IW(I).EQ.1990) THEN ETRANS(I)=ETRANS(I)/29979.2458 W(I)=8.98755E+8 ELSEIF(IW(I).EQ.1180) THEN ETRANS(I)=ETRANS(I)/29979.2458 W(I)=2.77393E+10 ELSEIF(IW(I).EQ.1130) THEN ETRANS(I)=ETRANS(I)/29979.2458 W(I)=5.31807E+10 ELSEIF(IW(I).EQ.1150) THEN ETRANS(I)=ETRANS(I)/29979.2458 W(I)=3.51076E+10 ELSEIF(IW(I).EQ.1160) THEN ETRANS(I)=ETRANS(I)/29979.2458 W(I)=3.99446E+10 ELSEIF(IW(I).EQ.1200) THEN ETRANS(I)=ETRANS(I)/29979.2458 W(I)=2.24688E+10 ELSEIF(IW(I).EQ.1080) THEN ETRANS(I)=ETRANS(I)/29979.2458 W(I)=1.4043E+11 ELSEIF(IW(I).EQ.1070) THEN ETRANS(I)=ETRANS(I)/29979.2458 W(I)=1.83419E+11 ELSEIF(IW(I).EQ.2000) THEN ETRANS(I)=ETRANS(I)/29979.2458 W(I)=2.24688E+8 ELSEIF(IW(I).EQ.1000.AND.IVOBS(1,I).EQ.1) THEN W(I)=5.61722E+11 ETRANS(I)=ETRANS(I)/29979.2458 ELSE IF(IW(I).EQ.10) THEN W(I)=4000000.0 ELSE IF(IW(I).EQ.2.OR.IW(I).EQ.3) THEN W(I)=4000000.0 ELSE W(I)=8E+6 ENDIF IF(ETRANS(I).EQ.-900.0000) THEN NADAT=I-1 GO TO 1 ENDIF I=I+1 GO TO 1 10 NDATA=I-1 PRINT*,NDATA,NADAT ELSE W(I)=1. C those format from fitk5jb| cjth I have changed these reads to follow standard conventions! c READ(5,225,END=11) ETRANS(I),IVOBS(1,I),NOBS(1,I), READ(5,225,END=11) ETRANS(I),IVOBS(2,I),NOBS(2,I), c A KOBS(1,I),PROBS(1,I),IBLK(1,I),IVOBS(2,I),NOBS(2,I), A KOBS(2,I),PROBS(2,I),IBLK(2,I),IVOBS(1,I),NOBS(1,I), c B KOBS(2,I),PROBS(2,I),IBLK(2,I),IAST(I),IW(I) B KOBS(1,I),PROBS(1,I),IBLK(1,I),IAST(I),IW(I) cjuan This command must be in to generate Juan's table. c iast(i)=1 C cjth I have added the following card in several places to eliminate vt=1. c if(ivobs(1,i).eq.1.and.ivobs(2,i).eq.1) go to 1 cjth I added these cards to make it unnecessary to input the IBLK values. iblk(1,I)=nobs(1,I)+1 iblk(2,I)=nobs(2,I)+1 c IJK debug 9 octobre 2006, change of sign of Pg-rho.Pa if(probs(1,I).eq.' ') then KOBS(1,I)=-KOBS(1,I) KOBS(2,I)=-KOBS(2,I) endif c C IF(IVOBS(2,I).EQ.3) IVOBS(2,I)=4 C IF(IVOBS(1,I).EQ.3) IVOBS(1,I)=4 WRITE(6,226) ETRANS(I),IVOBS(1,I),NOBS(1,I),KOBS(1,I) A,PROBS(1,I),IBLK(1,I),IVOBS(2,I),NOBS(2,I),KOBS(2,I) B,PROBS(2,I),IBLK(2,I),IAST(I),I,IW(I) 225 FORMAT (F12.5,1X,I3,1X,I3,1X,I3,1X,A1,1X,I3,1X,I3,1X,I3,1X, 1I3,1X,A1,1X,I3,1X,I3,1X,I4) 226 FORMAT (1X,F12.5,1X,I3,1X,I3,1X,I3,1X,A1,1X,I3,1X,I3,1X,I3,1X, 1I3,1X,A1,1X,I3,1X,I3,1X,I4,1X,I4) C the following cards to be turned in| C READ(5,23,END=11) ETRANS(I),IVOBS(1,I),NOBS(1,I), C A KOBS(1,I),PROBS(1,I),IBLK(1,I),IVOBS(2,I),NOBS(2,I), C B KOBS(2,I),PROBS(2,I),IBLK(2,I),IAST(I),IW(I),REF(I) C WRITE(6,26) ETRANS(I),IVOBS(1,I),NOBS(1,I),KOBS(1,I) C A ,PROBS(1,I),IBLK(1,I),IVOBS(2,I),NOBS(2,I),KOBS(2,I) C B ,PROBS(2,I),IBLK(2,I),IAST(I),I,IW(I),REF(I) C23 FORMAT (F12.5,I2,2X,I2,2X,I3,2X,A1,1X,I2,2X,I1,2X,I2,2X, C & I3,2X,A1,1X,I2,2X,I1,3X,I4,3X,A1) C25 FORMAT (F12.5,1X,I3,1X,I3,1X,I3,1X,A1,1X,I3,1X,I3,1X,I3,1X, C 1 I3,1X,A1,1X,I3,1X,I3,1X,I4,3X,A1) IF(ETRANS(I).EQ.-900.)THEN NADAT=I-1 GO TO 1 ENDIF I=I+1 GO TO 1 11 NDATA=I-1 PRINT*,NDATA,NADAT ENDIF C C NADAT:DNBREOF DATA A TYPE(SIGMA=0);NDATA:DNBRE OF TOTAL DATA C IF(NDATA.GT.(80000))THEN WRITE(6,*) ' TOO MANY DATA...' STOP ENDIF C3 FORMAT (F12.5,1X,I3,1X,I3,1X,I3,1X,A1,1X,I3,1X,I3,1X,I3,1X, C 1I3,1X,A1,1X,I3,1X,I3,1X,I4) 23 FORMAT (F12.5,I2,2X,I2,2X,I3,2X,A1,1X,I2,2X,I1,2X,I2,2X, & I3,2X,A1,1X,I2,2X,I1,3X,I4,3X,A6) 25 FORMAT (F12.5,1X,I3,1X,I3,1X,I3,1X,A1,1X,I3,1X,I3,1X,I3,1X, 1 I3,1X,A1,1X,I3,1X,I3,1X,I4,3X,A6) 26 FORMAT (1X,F12.5,1X,I3,1X,I3,1X,I3,1X,A1,1X,I3,1X,I3,1X,I3,1X, 1 I3,1X,A1,1X,I3,1X,I3,1X,I4,1X,I4,3X,A6) 24 FORMAT (1X,F12.5,1X,I3,1X,I3,1X,I3,1X,A1,1X,I3,1X,I3,1X,I3,1X, 1 I3,1X,A1,1X,I3,1X,I3,1X,I4,1X,I4,3X,A6) IF(IRMW.EQ.1) NP(2)=0 cjth I turned on this debugging statement. I turned it back off. c PRINT*, 'NP(1) A LA FIN DE DATA ',NP(1),'NP(2)= ',NP(2) RETURN END C************************************************************** SUBROUTINE DATA11(LO,CST) IMPLICIT REAL*8 ( A-H,O-Z ) C C READING OF THE CONSTANTS FOR EACH STATE AND PUTTING THEM IN C CST VECTOR C CHARACTER ABC*702 CHARACTER*1 PR,PROBS CHARACTER*4 ANSWER CHARACTER*6 PARA,REF COMMON/SYMB/ABC COMMON/CHARA/PARA(2,160),PR,PROBS(2,80000),REF(80000) COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRON1 , * IBGTME,IBGVTD ,EVIB(2),IRMW,TERM DIMENSION CST(2,117) NAMELIST/CSTE/OA,B,C,DJ,DJK,DK,ODELN,ODELK,HJ,HJK 1 ,HKJ,HK,OHJ,OHJK,OHK,FV,OFV,GV,ALV,AK1,AK2,AK3, 2 AK4,AK5,AK6,AK7,DAB,ODAB,DABJ,DABK,OLV,C1,C2,C3,HLKJ,AK5J, & C2J, 3 GVJ,AK2J,C1J,ANV,BK2,AMV,DAC,DBC,C4,ODELTA,DELTA,AK1J,AK5K, 4 AK2K,AK1K,AK3J,AK3K,BK1,AK7J,C11,ODAB6,AK6K,AK7K,AK66,AK6J, 5 AK3B,AK4B,DELTAB,ODELTB,C4J,C4K,C1K,C2K,C12, 6 ANVJ,AMVJ,AK3JJ,BK2J,BK1J,AK3KJ,BK1K,AK3KK,C3J,C12J,AK2JJ, 7 AK1JJ,AK2JK,AK1JK,AK3BJ,AK4BJ,AK3BB,AK4BB,ESPOIR,AK9,V12J, 8 V12K,DAC12,DBC12,DACJ,DBCJ,ODABJ,RHOB,RHOC, 9 F,RHO,V3,V6,V9,V12,RHORHO, ODABK,DACK,V9J,V9K,C11J,C11K, ! DABJJ,DABJK,ODABJJ,ODABJK C * Modification Denis Girou (CIRCE) * ABC = 'OA B C DJ DJK DK ODELN ODELK HJ HJK * 1 HKJ HK OHJ OHJK OHK FV OFV GV ALV AK1 AK2 * 2 AK3 AK4 AK5 AK6 AK7 DAB ODAB DABJ DABK OLV C1 * 3 C2 C3 HLKJ AK5J C2J GVJ AK2J C1J ANV BK2 AMV * 4 DAC DBC C4 ODELTADELTA AK1J AK5K AK2K AK1K AK3J AK3K * 5 F RHO V3 V6 V9 RHORHO' ABC(1:210)= & 'OA B C DJ DJK DK ODELN ODELK HJ HJK 1HKJ HK OHJ OHJK OHK FV OFV GV ALV AK1 AK2 2AK3 AK4 AK5 AK6 AK7 DAB ODAB DABJ DABK OLV C1 3C2 C3 HLKJ ' ABC(211:702)= 'AK5J C2J GVJ AK2J C1J ANV BK2 AMV 4DAC DBC C4 ODELTADELTA AK1J AK5K AK2K AK1K AK3J AK3K 5BK1 AK7J C11 ODAB6 AK6K AK7K AK66 AK6J AK3B AK4B DELTAB 6ODELTBC4J C4K C1K C2K C12 ANVJ AMVJ AK3JJ BK2J BK1J 7AK3KJ BK1K AK3KK C3J C12J AK2JJ AK1JJ AK2JK AK1JK AK3BJ AK4BJ 8AK3BB AK4BB ESPOIRAK9 V12J V12K DAC12 DBC12 DACJ DBCJ ODABJ 9RHOB RHOC F RHO V3 V6 V9 V12 RHORHOODABK DACK &V9J V9K C11J C11K DABJJ DABJK ODABJJODABJK' C INITIALISATION C OA=0.0 B=0.0 C=0.0 DJ=0.0 DJK=0.0 DK=0.0 ODELN=0.0 ODELK=0.0 HJ=0.0 HJK=0.0 HKJ=0.0 HK=0.0 OHJ=0.0 OHJK=0.0 OHK=0.0 FV=0.0 OFV=0.0 GV=0.0 ALV=0.0 AK1=0.0 AK2=0.0 AK3=0.0 AK4=0.0 AK5=0.0 AK6=0.0 AK7=0.0 DAB=0.0 DBC=0.0 C4=0.0 ODELTA=0.0 AK1J=0.0 AK5K=0.0 AK2K=0.0 AK1K=0.0 AK3J=0.0 AK3K=0.0 DELTA=0.0 ODAB=0.0 DABJ=0.0 DABK=0.0 OLV=0.0 C1=0.0 C2=0.0 C3=0.0 HLKJ=0.0 AK5J=0.0 C2J=0.0 GVJ=0.0 AK2J=0.0 C1J=0.0 ANV=0.0 BK2=0.0 AMV=0.0 DAC=0.0 DBC12=0.0 DAC12=0.0 BK1=0.0 AK7J=0.0 C11=0.0 ODAB6=0.0 AK6K=0.0 AK7K=0.0 AK66=0.0 AK6J=0.0 AK3B=0.0 AK4B=0.0 DELTAB=0.0 ODELTB=0.0 C4J=0.0 C4K=0.0 C1K=0.0 C2K=0.0 C12=0.0 ANVJ=0.0 AMVJ=0.0 AK3JJ=0.0 BK2J=0.0 BK1J=0.0 AK3KJ=0.0 F=0.0 RHO=0.0 V3=0.0 V6=0.0 V9=0.0 V12=0.0 V12J=0.0 V12K=0.0 BK1K=0.0 AK3KK=0.0 C3J=0.0 C12J=0.0 AK2JJ=0.0 AK1JJ=0.0 AK2JK=0.0 AK1JK=0.0 AK3BJ=0.0 AK4BJ=0.0 AK3BB=0.0 AK4BB=0.0 ESPOIR=0.0 DACJ=0.0 DBCJ=0.0 ODABJ=0.0 RHOB=0.0 RHOC=0.0 AK9=0.0 C RHOJ=0.0 C RHOK=0.0 RHORHO=0.0 ODABK=0.0 DACK=0.0 V9J=0.0 V9K=0.0 C11J=0. C11K=0. DABJJ=0. DABJK=0. ODABJJ=0. ODABJK=0. C C INITIALISATION C DO 3 II=1,(117) CST(LO,II)=0.0 3 CONTINUE C ASK THE USER FOR THE CONSTANT VALUES WRITE(6,132) 132 FORMAT(' CONSTANTS IN CM-1 OR IN MHZ? ',':DA') READ(5,'(A4)') ANSWER WRITE(6,'(A4)') ANSWER CONV=1. IF(ANSWER.EQ.'MHZ') CONV=29979.2458 C READ FROM NAMELIST READ(5,CSTE) WRITE(6,CSTE) C PUT THE CONSTANT VALUES IN CST VECTOR c my insertion c OPEN (35, FILE = 'dat', ACCESS = 'SEQUENTIAL', STATUS = 'NEW') c my insertion OPEN (35, FILE = 'dat', ACCESS = 'SEQUENTIAL', STATUS = 'unknown', ! form='unformatted') WRITE(35) OA,B,C,DJ,DJK,DK,ODELN,ODELK,HJ,HJK,HKJ,HK, 1 OHJ,OHJK,OHK,FV,OFV,GV,ALV,AK1,AK2,AK3,AK4,AK5,AK6,AK7, 2 DAB,ODAB,DABJ,DABK,OLV,C1,C2,C3,HLKJ,AK5J,C2J,GVJ,AK2J,C1J 3 ,ANV,BK2,AMV,DAC,DBC,C4,ODELTA,DELTA,AK1J,AK5K,AK2K,AK1K,AK3J 4 ,AK3K,BK1,AK7J,C11,ODAB6,AK6K,AK7K,AK66,AK6J,AK3B,AK4B,DELTAB 5 ,ODELTB,C4J,C4K,C1K,C2K,C12,ANVJ,AMVJ,AK3JJ,BK2J,BK1J,AK3KJ 6 ,BK1K,AK3KK,C3J,C12J,AK2JJ,AK1JJ,AK2JK,AK1JK,AK3BJ,AK4BJ 7 ,AK3BB,AK4BB,ESPOIR,AK9,V12J,V12K,DAC12,DBC12,DACJ,DBCJ 8 ,ODABJ,RHOB,RHOC 9 ,F,RHO,V3,V6,V9,V12,RHORHO,ODABK,DACK,V9J,V9K,C11J,C11K ! ,DABJJ,DABJK,ODABJJ,ODABJK REWIND 35 READ(35) (CST(LO,II),II=1,(117)) REWIND 35 DO 18 III=1,100 CST(LO,III)=CST(LO,III)/CONV 18 CONTINUE CST(LO,108)=CST(LO,108)/CONV CST(LO,109)=CST(LO,109)/CONV CST(LO,110)=CST(LO,110)/CONV CST(LO,111)=CST(LO,111)/CONV CST(LO,112)=CST(LO,112)/CONV CST(LO,113)=CST(LO,113)/CONV CST(LO,114)=CST(LO,114)/CONV CST(LO,115)=CST(LO,115)/CONV CST(LO,116)=CST(LO,116)/CONV CST(LO,117)=CST(LO,117)/CONV C PRINT*,CST(LO,38) C PRINT*,RHO,CST(LO,1) RETURN END C*********************************************************** SUBROUTINE ENCAL(E,LO,EGVL,EGVC,A) use assig IMPLICIT REAL*8 ( A-H,O-Z ) C*********************************************************** CHARACTER*1 PR,PROBS CHARACTER*6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1) COMMON/EIGEN/H(NDMX,NDMX),WORK(NDMX),EGVC3(KDMX,9),NBR(2) COMMON/ROTOR/NROTOR,NDIMTO COMMON/QUANT/ISIG,IV,N,KK COMMON/QUANT2/KKK(NDMX),NVT(NDMX),IPRITY(NDMX) COMMON/C2C/PERC2L,PER23L(NDMX) COMMON/CHARA/PARA(2,160),PR,PROBS(2,80000),REF(80000) DIMENSION EGVL(NDMX),EGVC(NDMX,NDMX),A(9,NTORMX,KDMX) DIMENSION EGVC4(KDMX,NTORMX,NDMX) C TAKE THE GOOD EIGENVALUE(E) AND ASSOCIATE A NUMBER(NBR) C TO THE EIGENVECTOR CORRESPONDING TO THE K DATA c call IPOSA or IPOSE or call eseign or aseign nbr(LO)=1 C IF(ISIG.EQ.0) THEN DO 5 J=1,NROTOR IVTORP=1 DO 4 I=1,NROTOR IU=(2*N+1)*IVTORP+1 IF(I.EQ.IU) IVTORP=IVTORP+1 II=I-(2*N+1)*(IVTORP-1) EGVC4(II,IVTORP,J)=EGVC(I,J) C IF(N.EQ.1.AND.J.LE.12) THEN C PRINT*,'EGVC4=',EGVC4(II,IVTORP,J),'II=',II,'J=',J C 1,'IVTORP=',IVTORP,'EGVC=',EGVC(I,J),'I=',I C ENDIF 4 CONTINUE 5 CONTINUE C HERE WE ADDED ANOTHER FUNCTION : IN IPOSA ALL THE EIGENVALUES C ARE LABELLED, IN IPOSA2 WE ONLY HAVE TO GET THE RIGHT ONE. C THE WIGNER SUBROUTINE IS DOING THE ROTATION OF THE EIGENVECT. C SO WE PASS FROM THE RAM TO THE PAM AXIS SYTEM. IF (PR.EQ.'+') IPR=1 IF (PR.EQ.'-') IPR=0 c NBR(LO)=aseign(iv,n,ipr,kk) IF(KK.EQ.0.AND.IV.EQ.0)THEN NBR(LO)=IPOSA(EGVC,EGVL,A,EGVC4) ELSE NBR(LO)=IPOSA2(EGVC,EGVL,A,EGVC4,PR) ENDIF ELSE c NBR(LO)=eseign(iv,n,kk) IF(KK.EQ.(-N).AND.IV.EQ.0) THEN NBR(LO)=IPOSE(EGVC,EGVL) ELSE NBR(LO)=IPOSE2(EGVC,EGVL) ENDIF ENDIF if(nbr(LO).gt.ndmx)nbr(LO)=ndmx if(nbr(LO).lt.1)nbr(LO)=1 C PRINT*,' NBR= ',NBR(LO),' LO= ',LO E=EGVL(NBR(LO)) IVTORP=1 DO 3 I=1,NROTOR IU=(2*N+1)*IVTORP+1 IF(I.EQ.IU) IVTORP=IVTORP+1 II=I-(2*N+1)*(IVTORP-1) EGVC3(II,IVTORP)=EGVC(I,NBR(LO)) IF(IVTORP.GE.9) EGVC3(II,IVTORP)=0.0 C PRINT*,' EGVC(I,NBR(LO))= ',EGVC(I,NBR(LO)) C PRINT*,' EGVC3= ',EGVC3(II,IVTORP),' IVTORP= ',IVTORP 3 CONTINUE RETURN END CC********************************************************** FUNCTION H0 (K,IVTOR,KP,IVTORP,CST,LO,ETOR,A) IMPLICIT REAL*8 ( A-H,O-Z ) C*********************************************************** C SETS UP THE DIAGONAL ELEMENTS OF THE HAMILTONIAN CHARACTER ABC*702 CHARACTER*1 PR,PROBS CHARACTER*6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1) COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRON1 , * IBGTME,IBGVTD ,EVIB(2),IRMW,TERM COMMON/CHARA/PARA(2,160),PR,PROBS(2,80000),REF(80000) COMMON/ROTOR/NROTOR,NDIMTO COMMON/SYMB/ABC COMMON/QUANT/ISIG,IV,N,KK DIMENSION CST(2,117),A(9,NTORMX,KDMX),ETOR(KDMX,9) OA=CST(LO,1) B=CST(LO,2) C=CST(LO,3) DJ=CST(LO,4) DJK=CST(LO,5) DK=CST(LO,6) ODELN=CST(LO,7) ODELK=CST(LO,8) HJ=CST(LO,9) HJK=CST(LO,10) HKJ=CST(LO,11) HK=CST(LO,12) OHJ=CST(LO,13) OHJK=CST(LO,14) OHK=CST(LO,15) FV=CST(LO,16) OFV=CST(LO,17) GV=CST(LO,18) ALV=CST(LO,19) AK1=CST(LO,20) AK2=CST(LO,21) AK3=CST(LO,22) AK4=CST(LO,23) AK5=CST(LO,24) AK6=CST(LO,25) AK7=CST(LO,26) DAB=CST(LO,27) ODAB=CST(LO,28) ODABJ=CST(LO,98) OLV=CST(LO,31) C1=CST(LO,32) C2=CST(LO,33) C3=CST(LO,34) HLKJ=CST(LO,35) AK5J=CST(LO,36) C2J=CST(LO,37) GVJ=CST(LO,38) AK2J=CST(LO,39) C1J=CST(LO,40) ANV=CST(LO,41) BK2=CST(LO,42) AMV=CST(LO,43) AK1J=CST(LO,49) AK5K=CST(LO,50) AK2K=CST(LO,51) AK1K=CST(LO,52) AK3J=CST(LO,53) AK3K=CST(LO,54) BK1=CST(LO,55) AK7J=CST(LO,56) AK6K=CST(LO,59) AK7K=CST(LO,60) AK66=CST(LO,61) AK6J=CST(LO,62) AK3B=CST(LO,63) AK4B=CST(LO,64) ANVJ=CST(LO,72) AMVJ=CST(LO,73) AK3JJ=CST(LO,74) BK2J=CST(LO,75) BK1J=CST(LO,76) AK3KJ=CST(LO,77) BK1K=CST(LO,78) AK3KK=CST(LO,79) C3J=CST(LO,80) C12J=CST(LO,81) AK2JJ=CST(LO,82) AK1JJ=CST(LO,83) AK2JK=CST(LO,84) AK1JK=CST(LO,85) AK3BJ=CST(LO,86) AK4BJ=CST(LO,87) AK3BB=CST(LO,88) AK4BB=CST(LO,89) AK9=CST(LO,91) V12J=CST(LO,92) V12K=CST(LO,93) V9J=CST(LO,110) V9K=CST(LO,111) RHO=CST(LO,102) RHORHO=CST(LO,107) C RHOJ=CST(LO,60) C RHOK=CST(LO,61) IK=K+N +1 C INITIALISATION A1=0.0 A2=0.0 A3=0.0 A4=0.0 A4B=0.0 A4BB=0.0 A5BB=0.0 A5=0.0 A5B=0.0 A6=0.0 A7=0.0 A7=0.0 A8=0.0 A8B=0.0 A9B=0.0 A14B=0.0 A15B=0.0 A9=0.0 A10=0.0 A11=0.0 A12=0.0 A13=0.0 A14=0.0 A15=0.0 A16=0.0 A17=0.0 A10B=0.0 A11B=0.0 A16B=0.0 A17B=0.0 A18=0.0 A19=0.0 A20=0.0 A21=0.0 DO 9 II=1,NDIMTO KL=II-KTRON1 COEFA= A(IVTOR,II,IK) COFAAA =A(IVTORP,II,IK) IF (II.EQ.NDIMTO ) THEN COEFAA=0.0 ELSE COEFAA=A(IVTORP,II+1,IK) ENDIF IF(II.EQ.1) THEN COEFA4=0.0 ELSE COEFA4=A(IVTORP,II-1,IK) ENDIF IF(II.GT.(NDIMTO -2)) THEN COEFA5=0.0 ELSE COEFA5=A(IVTORP,II+2,IK) ENDIF IF(II.LE.2) THEN COEFA6=0.0 ELSE COEFA6=A(IVTORP,II-2,IK) ENDIF IF(II.GT.(NDIMTO -4)) THEN COEFA7=0.0 ELSE COEFA7=A(IVTORP,II+4,IK) ENDIF IF(II.LE.4) THEN COEFA8=0.0 ELSE COEFA8=A(IVTORP,II-4,IK) ENDIF IF(II.GT.(NDIMTO -3)) THEN COEFA9=0.0 ELSE COEFA9=A(IVTORP,II+3,IK) ENDIF IF(II.LE.3) THEN COEFA10=0.0 ELSE COEFA10=A(IVTORP,II-3,IK) ENDIF C RHOEFF=RHO+RHOJ*N*(N+1)+RHOK*K**2 RHOEFF=RHO RHOKSG =3.*KL+ISIG+RHOEFF*K RHOKK=3*(KL+1)+ISIG+RHOEFF*K RHOKK2=3*(KL+2)+ISIG+RHOEFF*K RHOKM1=3.*(KL-1)+ISIG+RHOEFF*K RHOKM2=3.*(KL-2)+ISIG+RHOEFF*K A1=A1+COEFA*COEFAA A2=A2+(COEFA*COFAAA )*(RHOKSG **2) A3=A3+COEFA*COFAAA *RHOKSG A4=A4+COEFA*COFAAA *RHOKSG **3 A4B=A4B+COEFA*COFAAA *RHOKSG **5 A4BB=A4BB+COEFA*COFAAA *RHOKSG **7 A5=A5+COEFA*COFAAA *RHOKSG **4 A5B=A5B+COEFA*COFAAA *RHOKSG **6 A5BB=A5BB+COEFA*COFAAA *RHOKSG **8 A6=A6+COEFA*COFAAA A7=A7+COEFA*COEFA4 A8=A8+COEFA*COEFA4*RHOKSG A8B=A8B+COEFA*COEFA6*RHOKSG A9=A9+COEFA*COEFAA*RHOKSG A9B=A9B+COEFA*COEFA5*RHOKSG A10=A10+COEFA*COEFA4*RHOKSG **2 A10B=A10B+COEFA*COEFA6*RHOKSG **2 A11=A11+COEFA*COEFAA*RHOKSG **2 A11B=A11B+COEFA*COEFA5*RHOKSG **2 A12=A12+COEFA*COEFA5 A13=A13+COEFA*COEFA6 A18=A18+COEFA*COEFA7 A19=A19+COEFA*COEFA8 A20=A20+COEFA*COEFA9 A21=A21+COEFA*COEFA10 A14=A14+COEFA*COEFAA*RHOKK A14B=A14B+COEFA*COEFA5*RHOKK2 A15=A15+COEFA*COEFA4*RHOKM1 A15B=A15B+COEFA*COEFA6*RHOKM2 A16=A16+COEFA*COEFAA*RHOKK**2 A16B=A16B+COEFA*COEFA5*RHOKK2**2 A17=A17+COEFA*COEFA4*RHOKM1**2 A17B=A17B+COEFA*COEFA6*RHOKM2**2 9 CONTINUE C PRINT*,' A1= ',A1,' A2= ',A2,' A3= ',A3,' A4= ',A4,' A5= ', C 1A5 H0=(0.5*(B+C)*(N*(N+1)-K**2)+OA*K**2)*A6 H0=H0+(FV+OFV*N*(N+1))*(A6-0.5*A7-0.5*A1)*N*(N+1) H0=H0+(ANV*N*(N+1))*(A6-0.5*A13-0.5*A12) H0=H0+(V12J*N*(N+1))*(A6-0.5*A18-0.5*A19) H0=H0+(V12K*K**2)*(A6-0.5*A18-0.5*A19) H0=H0+(V9J*N*(N+1))*(A6-0.5*A20-0.5*A21) H0=H0+(V9K*K**2)*(A6-0.5*A20-0.5*A21) H0=H0+(ANVJ*N*(N+1)*N*(N+1))*(A6-0.5*A13-0.5*A12) H0=H0+(A6-0.5*A12-0.5*A13)*(K**2)*BK2 H0=H0+(A6-0.5*A12-0.5*A13)*(K**2)*BK2J*N*(N+1) H0=H0+GV*A2*N*(N+1) H0=H0+GVJ*A2*N**2*(N+1)**2 H0=H0+ALV*K*A3*N*(N+1) H0=H0-K**2*DJK*N*(N+1)*A6 H0=H0-N*(N+1)*DJ*N*(N+1)*A6 H0=H0+AK1*K**3*A3 H0=H0+AK1K*K**5*A3 H0=H0+AK1JK*K**5*A3*N*(N+1) H0=H0+AK1J*K**3*A3*N*(N+1) H0=H0+AK1JJ*K**3*A3*N*(N+1)*N*(N+1) H0=H0+AK2*K**2*A2 H0=H0+AK2K*K**4*A2 H0=H0+AK2JK*K**4*A2*N*(N+1) H0=H0+AK2J*K**2*A2*N*(N+1) H0=H0+AK2JJ*K**2*A2*N*(N+1)*N*(N+1) C PRINT*,' H0= ',H0 H0=H0+AK3*K*A4 H0=H0+AK3B*K*A4B H0=H0+AK3BB*K*A4BB H0=H0+AK3BJ*K*A4B*N*(N+1) H0=H0+AK3J*K*A4*N*(N+1) H0=H0+AK3JJ*K*A4*N*(N+1)*N*(N+1) H0=H0+AK3K*K*A4*(K**2) H0=H0+AK3KK*K*A4*(K**4) H0=H0+AK3KJ*K*A4*(K**2)*N*(N+1) H0=H0+AK4*A5 H0=H0+AK4B*A5B H0=H0+AK4BB*A5BB H0=H0+AK4BJ*A5B*N*(N+1) H0=H0+AMV*A5*N*(N+1) H0=H0+AMVJ*A5*N*(N+1)*N*(N+1) H0=H0+BK1*A5*K**2 H0=H0+BK1K*A5*K**4 H0=H0+BK1J*A5*K**2*N*(N+1) H0=H0+AK5*K**2*(A6-0.5*A7-0.5*A1) H0=H0+AK5K*K**4*(A6-0.5*A7-0.5*A1) H0=H0+AK5J*K**2*(A6-0.5*A7-0.5*A1)*N*(N+1) H0=H0+AK6*K*(A3-0.5*A8-0.5*A9+A3-0.5*A14-0.5*A15) H0=H0+AK66*K*(A3-0.5*A8B-0.5*A9B+A3-0.5*A14B-0.5*A15B) H0=H0+AK6K*K*(A3-0.5*A8-0.5*A9+A3-0.5*A14-0.5*A15)*K**2 H0=H0+AK6J*K*(A3-0.5*A8-0.5*A9+A3-0.5*A14-0.5*A15)*N*(N+1) H0=H0+AK7*(A2-0.5*A10-0.5*A11+A2-0.5*A16-0.5*A17) H0=H0+AK9*(A2-0.5*A10B-0.5*A11B+A2-0.5*A16B-0.5*A17B) H0=H0+AK7K*(A2-0.5*A10-0.5*A11+A2-0.5*A16-0.5*A17)*K**2 H0=H0+AK7J*(A2-0.5*A10-0.5*A11+A2-0.5*A16-0.5*A17)*N*(N+1) C PRINT*,' AK7=',AK7,' A1=',A1,'RHOKSIG=',RHOKSIG,'RHOKK=', C 1RHOKK,'N=',N,'K=',K,'IVTOR=',IVTOR H0=H0-DK*K**4*A6 H0=H0+HJ*(N*(N+1))**3*A6 H0=H0+HJK*(N*(N+1)*K)**2*A6 H0=H0+HKJ*N*(N+1)*K**4*A6 H0=H0+HLKJ*K**6*N*(N+1)*A6 H0=H0+HK*K**6*A6 C PRINT*,' CONV = ',CONV C H0 = H0/CONV C PRINT*,' H0= ',H0 IF(IVTOR.EQ.IVTORP) H0=H0+ETOR(IK,IVTOR) C PRINT*,ETOR(IK,IVTOR) RETURN END C********************************************************** FUNCTION H1(K,IVTOR,KP,IVTORP,CST,LO,ETOR,A) IMPLICIT REAL*8 ( A-H,O-Z ) C********************************************************* C SETS UP THE ELEMENT K/K+OR-1,VT/VT' OF THE HAMILTONIAN C (ODAB) CHARACTER ABC*702 CHARACTER*1 PR,PROBS CHARACTER*6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1) COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRON1 , * IBGTME,IBGVTD ,EVIB(2),IRMW,TERM COMMON/ROTOR/NROTOR,NDIMTO COMMON/CHARA/PARA(2,160),PR,PROBS(2,80000),REF(80000) COMMON/SYMB/ABC COMMON/QUANT/ISIG,IV,N,KK DIMENSION CST(2,117),ETOR(KDMX,9),A(9,NTORMX,KDMX) RHO=CST(LO,102) C RHOJ=CST(LO,60) C RHOK=CST(LO,61) ODAB=CST(LO,28) ODABJ=CST(LO,98) ODABJJ=CST(LO,116) ODABJK=CST(LO,117) ODABK=CST(LO,108) DAC=CST(LO,44) DACJ=CST(LO,96) DACK=CST(LO,109) DAC12=CST(LO,94) ODAB6=CST(LO,58) IK=K+N +1 ISIGN=1 IF (KP.EQ.(K-1)) ISIGN=-1 A1=0.0 A2=0.0 A3=0.0 A4=0.0 A5=0.0 A6=0.0 A3B=0.0 A4B=0.0 DO 10 II=1,NDIMTO COEFA=A(IVTOR,II,IK) COEFA1=A(IVTORP,II,IK+ISIGN) IF (II.EQ.NDIMTO ) THEN COEFAA=0.0 COFAA1 =0.0 ELSE COEFAA=A(IVTOR,II+1,IK) COFAA1 =A(IVTORP,II+1,IK+ISIGN) ENDIF IF(II.GT.(NDIMTO-2)) THEN COEFA3=0.0 COEFA4=0.0 ELSE COEFA3=A(IVTOR,II+2,IK) COEFA4=A(IVTORP,II+2,IK+ISIGN) ENDIF IF(II.EQ.1) THEN COEFA2 =0.0 ELSE COEFA2 =A(IVTORP,II-1,IK+ISIGN) ENDIF C FOR SIN 12 alpha :ndimto-4 C FOR SIN 9 alpha :ndimto-3 C IF(II.GT.(NDIMTO-4)) THEN IF(II.GT.(NDIMTO-3)) THEN COFAA12=0.0 ELSE C COFAA12=A(IVTORP,II+4,IK+ISIGN) COFAA12=A(IVTORP,II+3,IK+ISIGN) ENDIF C IF(II.LE.4) THEN IF(II.LE.3) THEN COEFA12=0.0 ELSE C COEFA12=A(IVTORP,II-4,IK+ISIGN) COEFA12=A(IVTORP,II-3,IK+ISIGN) ENDIF A1=A1+COEFA*COEFA1 A2=A2+COEFAA*COEFA1 A3=A3+COEFA*COFAA1 A3B=A3B+COEFA*COFAA12 A4=A4+COEFA*COEFA2 A4B=A4B+COEFA*COEFA12 A5=A5+COEFA1*COEFA3 A6=A6+COEFA*COEFA4 10 CONTINUE C PRINT*,' A1= ',A1,' A2= ',A2,' A3= ',A3 NN=N*(N+1)-K*(K+ISIGN) ANN=FLOAT(NN) H1=ODAB*SQRT(ANN)*(K+0.5*ISIGN) H1=H1+ODABJ*SQRT(ANN)*(K+0.5*ISIGN)*(N*(N+1)) H1=H1+ODABJJ*SQRT(ANN)*(K+0.5*ISIGN)*(N*(N+1)*N*(N+1)) H1=H1+ODABK*SQRT(ANN)*0.5*(K**3+(K+1.0*ISIGN)**3) H1=H1+ODABJK*SQRT(ANN)*N*(N+1)*0.5*(K**3+(K+1.0*ISIGN)**3) H1=H1*(A1-0.5*(A2+A3)) H1=H1+ODAB6*SQRT(ANN)*(K+0.5*ISIGN)*(A1-0.5*(A5+A6)) H1=H1+(-ISIGN)*(DAC/2.0)*SQRT(ANN)*(K+0.5*ISIGN)*(A4-A3) H1=H1+(-ISIGN)*(DACJ/2.0)*SQRT(ANN)*(K+0.5*ISIGN)*(A4-A3) 1*(N*(N+1)) H1=H1+(-ISIGN)*(DACK/2.0)*SQRT(ANN) &*0.5*(K**3+(K+1.0*ISIGN)**3) &*(A4-A3) H1=H1+(-ISIGN)*(DAC12/2.0)*SQRT(ANN)*(K+0.5*ISIGN)* 1(A4B-A3B) C H1 = H1/CONV RETURN END C*********************************************************** FUNCTION H2(K,IVTOR,KP,IVTORP,CST,LO,ETOR,A) IMPLICIT REAL*8 ( A-H,O-Z ) C C SETS UP THE K/K+OR-1 ELEMENTS(DAB) CHARACTER ABC*702 CHARACTER*1 PR,PROBS CHARACTER*6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1) COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRON1 , * IBGTME,IBGVTD ,EVIB(2),IRMW,TERM COMMON/CHARA/PARA(2,160),PR,PROBS(2,80000),REF(80000) COMMON/ROTOR/NROTOR,NDIMTO COMMON/SYMB/ABC COMMON/QUANT/ISIG,IV,N,KK DIMENSION CST(2,117),ETOR(KDMX,9),A(9,NTORMX,KDMX) RHO=CST(LO,102) DAB=CST(LO,27) DABJ=CST(LO,29) DABK=CST(LO,30) ODABK=CST(LO,108) DACK=CST(LO,109) ODELTA=CST(LO,47) DELTA=CST(LO,48) DELTAB=CST(LO,65) ODELTB=CST(LO,66) ESPOIR=CST(LO,90) DABJJ=CST(LO,114) DABJK=CST(LO,115) C RHOJ=CST(LO,60) C RHOK=CST(LO,61) IK=K+N +1 ISIGN=1 IF (KP.EQ.(K-1)) ISIGN=-1 A1=0.0 A2=0.0 A3=0.0 A2B=0.0 A3B=0.0 A4=0.0 DO 11 II=1,NDIMTO KL=II-KTRON1 COEFA=A(IVTOR,II,IK) COEFA1=A(IVTORP,II,IK+ISIGN) C RHOEFF=RHO+RHOJ*N*(N+1)+RHOK*K**2 RHOEFF=RHO RHOKSG =(3.*KL+ISIG+RHOEFF*(K+ISIGN))*((K+ISIGN)**2) RHOKSH =(3.*KL+ISIG+RHOEFF*(K+ISIGN))**3*((K+ISIGN)**2) RHOKS2 =(3.*KL+ISIG+RHOEFF*K)*(K**2) RHOKSI =(3.*KL+ISIG+RHOEFF*K)**3*(K**2) RHOKS3 =3.*KL+ISIG+RHOEFF*K RHOKS4 =3.*KL+ISIG+RHOEFF*(K+ISIGN) A1=A1+COEFA*COEFA1 A2=A2+COEFA*COEFA1*(RHOKSG +RHOKS2 ) A2B=A2B+COEFA*COEFA1*(RHOKSH +RHOKSI) A3=A3+COEFA*COEFA1*(RHOKS3 **2*K+RHOKS4 **2*(K+ISIGN)) A3B=A3B+COEFA*COEFA1*(RHOKS3 **4*K+RHOKS4 **4*(K+ISIGN)) A4=A4+COEFA*COEFA1*(RHOKS3)**3 11 CONTINUE C PRINT*,' A1= ',A1 C PRINT*,' A1= ',A1 NN=N*(N+1)-K*(K+ISIGN) ANN=FLOAT(NN) C H2=DAB*SQRT(ANN)*(K+0.5*ISIGN)*A1+DABJ*SQRT(ANN)*(K+0.5*ISIGN) C * *A1*N*(N+1)+DABK*SQRT(ANN)*(K+0.5*ISIGN)*A1*K**2 C******DABK TERM MADE HERMITIAN BY JTH 18 APR 92. C H2=DAB*SQRT(ANN)*(K+0.5*ISIGN)*A1+DABJ*SQRT(ANN)*(K+0.5*ISIGN) C * *A1*N*(N+1)+DABK*SQRT(ANN)*(K+0.5*ISIGN)*A1*K**2 H2=DAB*SQRT(ANN)*(K+0.5*ISIGN)*A1 * +DABJ*SQRT(ANN)*(K+0.5*ISIGN)*A1*N*(N+1) * +DABK*SQRT(ANN)*0.5*(K**3+(K+1.0*ISIGN)**3)*A1 H2=H2+DABJJ*SQRT(ANN)*(K+0.5*ISIGN)*A1*N*(N+1)*N*(N+1) H2=H2+DABJK*SQRT(ANN)*0.5*(K**3+(K+1.0*ISIGN)**3)*A1*N*(N+1) H2=H2+ODELTA*A2*SQRT(ANN)*0.5 H2=H2+ODELTB*A2B*SQRT(ANN)*0.5 H2=H2+DELTA*A3*SQRT(ANN)*0.5 H2=H2+DELTAB*A3B*SQRT(ANN)*0.5 H2=H2+ESPOIR*A4*SQRT(ANN)*0.5 C H2 = H2/CONV C PRINT*,' H2= ',H2 RETURN END C************************************************************ FUNCTION H3(K,IVTOR,KP,IVTORP,CST,LO,ETOR,A) IMPLICIT REAL*8 ( A-H,O-Z ) C C SETS UP THE K/K+-2 ELEMENTS CHARACTER ABC*702 CHARACTER*1 PR,PROBS CHARACTER*6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1) COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRON1 , * IBGTME,IBGVTD ,EVIB(2),IRMW,TERM COMMON/CHARA/PARA(2,160),PR,PROBS(2,80000),REF(80000) COMMON/ROTOR/NROTOR,NDIMTO COMMON/SYMB/ABC COMMON/QUANT/ISIG,IV,N,KK DIMENSION CST(2,117),A(9,NTORMX,KDMX),ETOR(KDMX,9) OA=CST(LO,1) B=CST(LO,2) C=CST(LO,3) DJ=CST(LO,4) DJK=CST(LO,5) DK=CST(LO,6) ODELN=CST(LO,7) ODELK=CST(LO,8) HJ=CST(LO,9) HJK=CST(LO,10) HKJ=CST(LO,11) HK=CST(LO,12) OHJ=CST(LO,13) OHJK=CST(LO,14) OHK=CST(LO,15) FV=CST(LO,16) OFV=CST(LO,17) GV=CST(LO,18) ALV=CST(LO,19) AK1=CST(LO,20) AK2=CST(LO,21) AK3=CST(LO,22) AK4=CST(LO,23) AK5=CST(LO,24) AK6=CST(LO,25) AK7=CST(LO,26) DAB=CST(LO,27) ODAB=CST(LO,28) OLV=CST(LO,31) C1=CST(LO,32) C2=CST(LO,33) C3=CST(LO,34) C11=CST(LO,57) C11J=CST(LO,112) C11K=CST(LO,113) HLKJ=CST(LO,35) RHO=CST(LO,102) C RHOJ=CST(LO,60) C RHOK=CST(LO,61) C2J=CST(LO,37) GVJ=CST(LO,38) AK2J=CST(LO,39) C1J=CST(LO,40) DBC=CST(LO,45) DBCJ=CST(LO,97) DBC12=CST(LO,95) C4=CST(LO,46) C4J=CST(LO,67) C4K=CST(LO,68) C1K=CST(LO,69) C2K=CST(LO,70) C12=CST(LO,71) C3J=CST(LO,80) C12J=CST(LO,81) IK=K+N +1 ISIGN=2 C PRINT*,' C1= ',C1,' C2= ',C2,' C3= ',C3,' OHJK= ', C 1 OHJK,' ODELN= ',ODELN,' ODELK= ',ODELK,' OHJ= ',OHJ,' OHK= ' C 2 ,OHK C PRINT*,'C4J=',C4J IF (KP.EQ.(K-2)) ISIGN=-2 A1=0.0 A2=0.0 A3=0.0 A4=0.0 A5=0.0 A6=0.0 A7=0.0 A8=0.0 A9=0.0 A10=0.0 A11=0.0 A4B=0.0 A6B=0.0 DO 12 II=1,NDIMTO KL=II-KTRON1 COEFA=A(IVTOR,II,IK) COEFA2=A(IVTORP,II,IK+ISIGN) IF (II.EQ.NDIMTO ) THEN COEFA1=0.0 COFAA2 =0.0 ELSE COEFA1=A(IVTOR,II+1,IK) COFAA2 =A(IVTORP,II+1,IK+ISIGN) ENDIF IF(II.EQ.1) THEN COEFA3 =0.0 ELSE COEFA3 =A(IVTORP,II-1,IK+ISIGN) ENDIF CC IF(II.LE.4) THEN IF(II.LE.3) THEN COEFA12=0.0 ELSE C COEFA12=A(IVTORP,II-4,IK+ISIGN) COEFA12=A(IVTORP,II-3,IK+ISIGN) ENDIF IF(II.GT.(NDIMTO-2)) THEN COEFA4=0.0 COEFAA4=0.0 ELSE COEFA4=A(IVTOR,II+2,IK) COEFAA4=A(IVTORP,II+2,IK+ISIGN) ENDIF C IF(II.GT.(NDIMTO-4)) THEN IF(II.GT.(NDIMTO-3)) THEN COFAA12=0.0 ELSE C COFAA12=A(IVTORP,II+4,IK+ISIGN) COFAA12=A(IVTORP,II+3,IK+ISIGN) ENDIF C RHOEFF=RHO+RHOJ*N*(N+1)+RHOK*K**2 RHOEFF=RHO RHOKSG =3.*KL+ISIG+RHOEFF*K RHOKS2 =(3.*KL+ISIG+RHOEFF*(K+ISIGN))*(K+ISIGN) RHOKS3 =(3.*KL+ISIG+RHOEFF*K)*(K) RHOK2=3.*KL+ISIG+RHOEFF*(K+ISIGN) RHOKS4=(3.*KL+ISIG+RHOEFF*K)**3 RHOKS4=RHOKS4*K RHOKS5=(3.*KL+ISIG+RHOEFF*(K+ISIGN))**3 RHOKS5=RHOKS5*(K+ISIGN) RHOKS6=(3.*KL+ISIG+RHOEFF*K)*(K) RHOKS6=RHOKS6*(K+ISIGN)**2 RHOKS7=(3.*KL+ISIG+RHOEFF*(K+ISIGN))*(K+ISIGN) RHOKS7=RHOKS7*(K)**2 A1=A1+COEFA*COEFA2 C PRINT*,' COEFA= ',COEFA,' COEFA1= ',COEFA1,' COEFA2= ', C 1COEFA2,' COEFAA2= ',COEFAA2 A2=A2+COEFA*COEFA2*(RHOKSG **2+RHOK2**2) A3=A3+COEFA1*COEFA2 A4=A4+COEFA*COFAA2 A4B=A4B+COEFA*COFAA12 A5=A5+COEFA*COEFA2*(RHOKSG **4+RHOK2**4) A6=A6+COEFA*COEFA3 A6B=A6B+COEFA*COEFA12 A7=A7+COEFA*COEFA2*(RHOKS2 +RHOKS3 ) A8=A8+COEFA2*COEFA4 A9=A9+COEFA*COEFAA4 A10=A10+COEFA*COEFA2*(RHOKS4+RHOKS5) A11=A11+COEFA*COEFA2*(RHOKS6+RHOKS7) 12 CONTINUE C PRINT*,' A1= ',A1,' A2= ',A2,' A3= ',A3,' A4= ',A4 C PRINT*,' K= ',K,' KP= ',KP,' IVTOR= ',IVTOR,' IVTORP= ', C 1IVTORP,' ISIGN= ',ISIGN H3=(B-C)/4.-ODELN*N*(N+1)-0.5*ODELK*(K**2+(K+ISIGN)**2)+ * OHJ*(N*(N+1))**2+0.5*OHJK*N*(N+1)*(K**2+(K+ISIGN)**2) * +0.5*OHK*(K**4+(K+ISIGN)**4) C PRINT*,' H3= ',H3 H3=A1*H3 H3=H3+0.5*C1*A2 H3=H3+0.5*C1J*A2*N*(N+1) C PRINT*,' H3= ',H3 H3=H3+0.5*C2*(A1-0.5*(A3+A4)) H3=H3+0.5*C2J*(A1-0.5*(A3+A4))*(N*(N+1)) H3=H3+0.5*C3*A5 H3=H3+0.5*C3J*A5*N*(N+1) H3=H3+0.5*C4*A7 H3=H3+0.5*C12*A10 H3=H3+0.5*C12J*A10*N*(N+1) H3=H3+0.5*C4J*A7*N*(N+1) C IF(N.EQ.1) PRINT*,'H3=',H3 H3=H3+0.5*C1K*(K**2+(K+ISIGN)**2)*A2 H3=H3+0.5*C2K*(A1-0.5*(A3+A4))*(K**2+(K+ISIGN)**2) H3=H3+0.5*C4K*A11 H3=H3+0.5*C11*(A1-0.5*(A8+A9)) H3=H3+0.5*C11J*(A1-0.5*(A8+A9))*N*(N+1) H3=H3+0.5*C11K*(A1-0.5*(A8+A9))*(K**2+(K+ISIGN)**2) ANN=N*(N+1)-K*(K+0.5*ISIGN) ALL=N*(N+1)-(K+0.5*ISIGN)*(K+ISIGN) H3=H3*SQRT(ANN*ALL) C PRINT*,' H3= ',H3 H3=H3+((A6-A4)*(-ISIGN)*0.5*DBC*(1./4.))*(SQRT(ANN*ALL)) H3=H3+((A6-A4)*(-ISIGN)*0.5*DBCJ*(1./4.))*(SQRT(ANN*ALL)) 1*(N*(N+1)) H3=H3+((A6B-A4B)*(-ISIGN)*0.5*DBC12*(1./4.))*(SQRT(ANN*ALL)) RETURN END C************************************************************** FUNCTION H4(K,IVTOR,KP,IVTORP,CST,LO,ETOR,A) IMPLICIT REAL*8 ( A-H,O-Z ) C************************************************************** C SETS UP THE ELEMENT K/K,VT,VT'(OLV) CHARACTER ABC*702 CHARACTER*1 PR,PROBS CHARACTER*6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1) COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRON1 , * IBGTME,IBGVTD ,EVIB(2),IRMW,TERM COMMON/CHARA/PARA(2,160),PR,PROBS(2,80000),REF(80000) COMMON/ROTOR/NROTOR,NDIMTO COMMON/SYMB/ABC COMMON/QUANT/ISIG,IV,N,KK DIMENSION CST(2,117),ETOR(KDMX,9),A(9,NTORMX,KDMX) RHO=CST(LO,102) C RHOJ=CST(LO,60) C RHOK=CST(LO,61) OLV=CST(LO,31) IK=K+N +1 A1=0.0 DO 25 II=1,NDIMTO KL=II-KTRON1 COEFA=A(IVTOR,II,IK) COEFAA=A(IVTORP,II,IK) C RHOEFF=RHO+RHOJ*N*(N+1)+RHOK*K**2 RHOEFF=RHO RHOKSG =3.*KL+ISIG+RHOEFF*K A1=A1+COEFA*COEFAA*RHOKSG 25 CONTINUE C H4=OLV*N*(N+1)*K**3*A1 C OLV SHOULD BE A J(J+1) DEPENDANCE OF ALV H4=OLV*N*(N+1)*K*A1*N*(N+1) C H4=H4/CONV RETURN END C************************************************************ SUBROUTINE HRTSET(CST,LO,ETOR,A) IMPLICIT REAL*8 ( A-H,O-Z ) C************************************************************ C SETS UP THE ROTATION-TORSION HAMILTONIAN CHARACTER ABC*702 CHARACTER*1 PR,PROBS CHARACTER*6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1) COMMON/EIGEN/H(NDMX,NDMX),WORK(NDMX),EGVC3(KDMX,9),NBR(2) COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRON1 , * IBGTME,IBGVTD ,EVIB(2),IRMW,TERM COMMON/ROTOR/NROTOR,NDIMTO COMMON/SYMB/ABC COMMON/QUANT/ISIG,IV,N,KK COMMON/CHARA/PARA(2,160),PR,PROBS(2,80000),REF(80000) DIMENSION CST(2,117),A(9,NTORMX,KDMX),ETOR(KDMX,9) DO 3 I=1,NROTOR DO 4 J=1,I C INITIALISATION H(I,J)=0.0 4 CONTINUE 3 CONTINUE DO 7 I=1,NROTOR DO 8 J=1,I C LEFT-SIDE MATRIX ELEMENT IVTOR=(I-1)/(2*N+1)+1 K=I+N*(1 -2*IVTOR)-IVTOR C RIGHT-SIDE MATRIX ELEMENT IVTORP=(J-1)/(2*N+1)+1 KP=J+N*(1 -2*IVTORP)-IVTORP C C K=KP C PRINT*,' K= ',K,' KP= ',KP,' IVTOR= ',IVTOR,' IVTORP= ', C 1IVTORP IF (K.EQ.KP) THEN C IF(IVTOR.EQ.IVTORP) THEN H(I,J)= H0(K,IVTOR,KP,IVTORP,CST,LO,ETOR,A) 1 + H4(K,IVTOR,KP,IVTORP,CST,LO,ETOR,A) C PRINT*,' (I,J)= ',H(I,J),' I= ',I,' J= ',J C PRINT*,'H0=',H0(K,IVTOR,KP,IVTORP,CST,LO,ETOR,A), C 1'K=',K,'IVTOR=',IVTOR,'KP=',KP,'IVTORP=',IVTORP, C 2'LO=',LO C PRINT*,'H4=',H4(K,IVTOR,KP,IVTORP,CST,LO,ETOR,A) C ENDIF ELSE IF (IABS(K-KP).EQ.1) THEN IF (IABS(IVTOR-IVTORP).LT.9) THEN H(I,J)= H2(K,IVTOR,KP,IVTORP,CST,LO,ETOR,A) 1 + H1(K,IVTOR,KP,IVTORP,CST,LO,ETOR,A) C PRINT*,' H(I,J)= ',H(I,J),' I= ',I,' J= ',J C PRINT*,'H2=',H2(K,IVTOR,KP,IVTORP,CST,LO,ETOR,A) C PRINT*,'H1=',H1(K,IVTOR,KP,IVTORP,CST,LO,ETOR,A) ENDIF ELSE IF(IABS(K-KP).EQ.2) THEN IF (IABS(IVTOR-IVTORP).LT.9) THEN H(I,J)= H3(K,IVTOR,KP,IVTORP,CST,LO,ETOR,A) C PRINT*,' H(I,J)= ',H(I,J),' I= ',I,' J= ',J C PRINT*,'H3=',H3(K,IVTOR,KP,IVTORP,CST,LO,ETOR,A) ENDIF ENDIF 8 CONTINUE 7 CONTINUE DO 20 I=2,NROTOR DO 21 J=1,I-1 H(J,I)=H(I,J) 21 CONTINUE 20 CONTINUE RETURN END C******************************************************** SUBROUTINE HTORSE (K,CST,LO) IMPLICIT REAL*8 ( A-H,O-Z ) C C SETS UP THE TORSION HAMILTANIAN C C THIS SUBROUTINE SETS UP THE TORSION HAMILTONIAN C CHARACTER ABC*702 CHARACTER*1 PR,PROBS CHARACTER*6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1) COMMON/EIGEN/H(NDMX,NDMX),WORK(NDMX),EGVC3(KDMX,9),NBR(2) COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRON1 , * IBGTME,IBGVTD ,EVIB(2),IRMW,TERM COMMON/SYMB/ABC COMMON/QUANT/ISIG,IV,N,KK COMMON/ROTOR/NROTOR,NDIMTO COMMON/CHARA/PARA(2,160),PR,PROBS(2,80000),REF(80000) DIMENSION CST(2,117) C C LOOP ON THE BASIS FUNCTIONS F=CST(LO,101) RHO=CST(LO,102) C RHOJ=CST(LO,60) C RHOK=CST(LO,61) RHORHO=CST(LO,107) V3=CST(LO,103) V6=CST(LO,104) V9=CST(LO,105) V12=CST(LO,106) C INITIALISATION DO 3 I=1,NDIMTO DO 4 J=1,I H(I,J)=0.0 4 CONTINUE 3 CONTINUE C C KTOR:DLEFT SIDE OF THE MATRIX ELEMENT C KTORP:DRIGHT SIDE OF THE MATRIX ELEMENT C DO 10 I=1,NDIMTO DO 11 J=1,I KTOR=I - KTRON1 KTORP=J - KTRON1 C RHOEFF=RHORHO+RHOJ*N*(N+1)+RHOK*K**2 RHOEFF=RHORHO C C KTOR=KTORP C C PRINT*,' KTOR= ',KTOR,' KTORP= ',KTORP IF (KTOR.EQ.KTORP) THEN c H(I,J) = F*(3.*KTOR+ISIG+RHOEFF*K)**2+V3/2. c & +V6/2.+V9/2.+V12/2. cdebugik, 2Frho.pa.pg sign changed! H(I,J) = F*(3.*KTOR+ISIG-RHOEFF*K)**2+V3/2. & +V6/2.+V9/2.+V12/2. C PRINT*,' H= ',H(I,J) ELSE IF(IABS(KTOR-KTORP).EQ.1) THEN C C KTOR=KTORP+1 OR KTOR=KTORP-1 C H(I,J) = -V3/4. ELSE IF (IABS(KTOR-KTORP).EQ.2) THEN C C KTOR=KTORP+2 OR KTOR=KTORP-2 C H(I,J) = -V6/4. ELSE IF(IABS(KTOR-KTORP).EQ.3) THEN H(I,J)=-V9/4. ELSE IF(IABS(KTOR-KTORP).EQ.4) THEN H(I,J)=-V12/4. ENDIF 11 CONTINUE 10 CONTINUE C SYMETRISES THE MATRIX DO 5 I=2,NDIMTO DO 6 J=1,I-1 H(J,I) = H(I,J) 6 CONTINUE 5 CONTINUE RETURN END c******************************************************************** SUBROUTINE PARITY(A,EGVC4,II) c my insertion IMPLICIT REAL*8 ( A-H,O-Z ) C THIS SUBROUTINE CALCULATES THE TRUE PARITY OF THE CURRENT STATE C (+or-).(-1)J+VT = "true" parity C**************************************************************** CHARACTER*1 PR,PROBS CHARACTER*6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1) COMMON/ROTOR/NROTOR,NDIMTO COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRON1 , * IBGTME,IBGVTD ,EVIB(2),IRMW,TERM COMMON/QUANT2/KKK(NDMX),NVT(NDMX),IPRITY(NDMX) COMMON/C2C/PERC2L,PER23L(NDMX) COMMON/EIGEN/H(NDMX,NDMX),WORK(NDMX),EGVC3(KDMX,9),NBR(2) COMMON/QUANT/ISIG,IV,N,KK COMMON/CHARA/PARA(2,160),PR,PROBS(2,80000),REF(80000) DIMENSION A(9,NTORMX,KDMX) DIMENSION EGVC4(KDMX,NTORMX,NDMX) C NLOW=N NLOW1 = NLOW+1 C P OR PRIME STANDS FOR LEFT OR LOWER KNP2=2*NLOW KLOW=KK IVVLO=IV PERC2L=0.0 PER23L(II)=0. C INITIALIZATION OF THE SUM ON TORSIONAL EIGENFUNCTIONS AN00A=0.0 AN00B=0.0 AN00C=0.0 AN01A=0.0 AN01B=0.0 AN01C=0.0 AN0M1A=0.0 AN0M1B=0.0 AN0M1C=0.0 AN10A=0.0 AN10B=0.0 AN10C=0.0 AN11A=0.0 AN11B=0.0 AN11C=0.0 AN1M1A=0.0 AN1M1B=0.0 AN1M1C=0.0 ANM10A=0.0 ANM10B=0.0 ANM10C=0.0 ANM11A=0.0 ANM11B=0.0 ANM11C=0.0 ANM1MA=0.0 ANM1MB=0.0 ANM1MC=0.0 C C EXPECTATION VALUE OF C2(C) AND OF (23)* FOR CURRENT STATE C DO 304 IVTORP=1,9 DO 302 IVTOR1=1,9 DO 300 ILOW=1,2*NLOW+1 KBASLO=ILOW-NLOW-1 IOPPLO=-KBASLO+NLOW+1 NPKLO=NLOW+KBASLO EXPPLO=1. IF(MOD(NPKLO,2).NE.0) EXPPLO=-1. A2LO=0.0 A3LO=0.0 DO 298 III=1,NDIMTO IIIOPP=2*KTRONC+1-(III-1) COEFAL=A(IVTORP,III,ILOW) COEFAAL=A(IVTOR1,III,IOPPLO) IF(ISIG.EQ.0) THEN COEF4L=A(IVTOR1,IIIOPP,IOPPLO) ELSE COEF4L=0.0 ENDIF A2LO=A2LO+COEFAL*COEFAAL A3LO=A3LO+COEFAL*COEF4L 298 CONTINUE PERC2L=PERC2L+A2LO*EXPPLO* 1 EGVC4(ILOW,IVTORP,II)*EGVC4(IOPPLO,IVTOR1,II) PER23L(II)=PER23L(II)+A3LO*EXPPLO* 1 EGVC4(ILOW,IVTORP,II)*EGVC4(IOPPLO,IVTOR1,II) C IF(N.EQ.1) PRINT*,'EGVC4(K)=',EGVC4(ILOW,IVTORP,II), C 1 'EGVC4(-K)=',EGVC4(IOPPLO,IVTOR1,II),'ILOW=',ILOW, C 2 'IVTORP=',IVTORP,'II=',II C PRINT*,'PER23L=',PER23L,'A3LO=',A3LO,'NLOW=',NLOW,'KK=',KK,'IV=',IV C 1,'EGVC3=',EGVC3(ILOW,IVTORP),'EGVC3(-K)=',EGVC3(IOPPLO,IVTOR1) 300 CONTINUE 302 CONTINUE 304 CONTINUE C PRINT*,'PER23L=',PER23L,'N=',N,'IV=',IV,'KK=',KK RETURN END C*********************************************************** FUNCTION IREP(SYMBOL) IMPLICIT REAL*8 ( A-H,O-Z ) C THIS FUNCTION RECOGNIZE THE SYMBOLIC CONSTANT ENCOUNTERED C ON TAPE 5 AND RETURNS ITS POSITION IN THE ABC STRING CHARACTER SYMBOL*6,ABC*702 COMMON/SYMB/ABC DO 1 K=1,(117) IF(SYMBOL.EQ.ABC(6*(K-1)+1:6*K)) THEN IREP=K RETURN END IF 1 CONTINUE WRITE(6,100) SYMBOL 100 FORMAT(//,' NO MATCHING CONSTANT SYMBOL FOR ',A6,/) STOP END SUBROUTINE LINECA (CST,NPP) IMPLICIT REAL*8 ( A-H,O-Z ) C THIS SUBROUTINE CALCULATES AND WRITES C 1) THE OBS-CALC FOR ALL THE EXPERIMENTAL DATA C 2) THE ENERGY OF THE LINES GIVEN C C********************************************************* CHARACTER ABC*702 CHARACTER*6 PARA,REF CHARACTER*1 AST CHARACTER*1 PR,PROBS,PRSUP,PRINF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1) COMMON/EIGEN/H(NDMX,NDMX),WORK(NDMX),EGVC3(KDMX,9),NBR(2) COMMON/EIGEN1/EGVL(2*NDMX),EGVC(NDMX,2*NDMX) COMMON/TOR/A(9,NTORMX,2*KDMX),ETOR(2*KDMX,9) COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRON1 , * IBGTME,IBGVTD ,EVIB(2),IRMW,TERM COMMON/ROTOR/NROTOR,NDIMTO COMMON/BIG2/DERIV1(10,961,80),ENER(10,961) COMMON/EXPDAT / ETRANS(80000),IVOBS(2,80000), * NOBS(2,80000),KOBS(2,80000),IBLK(2,80000),IW(80000),W(80000), * NDATA,NADAT,EPSI,NOFIT,NFITMW,NFITIR,NFIMW0 ,NFIMW1 ,NITT, * IAST(80000),NFI004 ,NFI080 ,NFI100 ,NFI020 ,NFI200 ,NFI045 , & NGST0 ,NFI010 ,SW070,NFI070 ,NFIMW2,IKAKC,JMAX,NFI1M0, & NFIR10,NFIR21,NFIR32,NFIMW3,NFIMW4,SWA,SWE,NFITMWA,NFITMWE COMMON/SYMB/ABC COMMON/QUANT/ISIG,IV,N,KK COMMON/CHARA/PARA(2,160),PR,PROBS(2,80000),REF(80000) DIMENSION CST(2,117),IBLSTO(2),EE(2),KC(2,80000) S=0. SMW=0. SWA=0.0 SWE=0. SMW0=0.0 SMW1=0.0 SMW2=0.0 SMW3=0.0 SMW4=0.0 SIR=0. SIR10=0. SIR21=0. SIR32=0. SIG004=0. SIG080=0.0 SIG010=0.0 SIG100=0.0 SIG020=0.0 SIG200=0.0 SIG045=0.0 SIG1M0=0.0 SW070=0.0 SIG32=0.0 WMW=0. WMWA=0. WMWE=0. WMW0=0.0 WMW1=0.0 WMW2=0.0 WMW3=0.0 WMW4=0.0 WIR=0. WIR10=0. WIR21=0. WIR32=0. WIG004=0. WIG080=0.0 WIG010=0.0 WIG100=0.0 WIG020=0.0 WIG200=0.0 WIG045=0.0 WIG1M0=0.0 WIG070=0.0 SGST0=0. IBLSTO(1)=0 IBLSTO(2)=0 WRITE(6,602) 602 FORMAT(/,4X,' UPPER STATE',3X,' LOWER STATE',5X, 1 ' OBSERVATION ',8X,' CALCULATION',6X,' TME ',4X,' WEIGHT', 2 4X,' FITTED OR NO' 3 /,2(2X,' VT J KA KC PARITY')) DO 22 K=1,NDATA IF(NOBS(1,K).GT.JMAX.OR.NOBS(2,K).GT.JMAX) GO TO 22 C IF(K.GT.NADAT) THEN C ISIG=1 C ELSE C ISIG=0 C ENDIF C DO 24 II=1,2 C IF(II.EQ.1) THEN C NI=1 C M=1 C ELSE C NI=NDMX+1 C M=KDMX+1 C ENDIF C N=NOBS(II,K) C IV=IVOBS(II,K) C KK=KOBS(II,K) C PR=PROBS(II,K) C LOO=II C III=II C IF(IRMW.EQ.1.AND.II.EQ.2) III=1 C IF(IBLK(LOO,K).NE.IBLSTO(LOO)) THEN C IBLSTO(LOO)=IBLK(LOO,K) C CALL ROTTOR(CST,III,EGVL(NI),EGVC(1,NI),ETOR(M,1) C 1 ,A(1,1,M)) C ENDIF C NROTOR=(2*N+1)*9 C CALL ENCAL(E,LOO,EGVL(NI),EGVC(1,NI)) C EE(LOO)=E C24 CONTINUE DO 31 LO=1,2 N=NOBS(LO,K) KK=KOBS(LO,K) IV=IVOBS(LO,K) PR=PROBS(LO,K) IF(PR.EQ.'+') IPR=1 IF(PR.EQ.'-') IPR=0 IF(K.GT.NADAT) THEN ISIG=1 IVV=IV+6 INK=N**2+N+KK+1 ELSE ISIG=0 IVV=IV+1 INK=N**2+N+KK+1-IPR*N ENDIF EE(LO)=ENER(IVV,INK) 31 CONTINUE ECALC=TERM+EE(2)-EE(1) C IF(ECALC.LT.0.) THEN c NSUP=NOBS(2,K) c NINF=NOBS(1,K) c KSUP=KOBS(2,K) c KINF=KOBS(1,K) c PRSUP=PROBS(2,K) c PRINF=PROBS(1,K) c NOBS(2,K)=NINF c NOBS(1,K)=NSUP c KOBS(2,K)=KINF c KOBS(1,K)=KSUP c PROBS(2,K)=PRINF c PROBS(1,K)=PRSUP c ESUP=EE(2) c EINF=EE(1) c EE(2)=EINF c EE(1)=ESUP c ECALC=TERM+EE(2)-EE(1) c ENDIF C HERE, THE USER HAS THE POSSIBILITY OF HAVING A PRINT OUT C INCLUDING THE JKAKC NOTATION AND THE INTERNAL ROTOR NOTATION C BUT, FOR THE E STATES,SINCE THERE IS NO SYMMETRY RULES ALLOW C THE CONVERSION, IT IS BASED ON ENERGY LEVELS ORDER,M WHICH cjth IS MOLECULE DEPENDANT:DHERE IT IS FOR CH3COOH ONLY! IF(IKAKC.NE.1) GO TO 60 IF(ISIG.EQ.0) THEN IF(MOD(KOBS(1,K),2).EQ.0) THEN IF(PROBS(1,K).EQ.'+') THEN KC(1,K)=NOBS(1,K)-KOBS(1,K) ELSE KC(1,K)=NOBS(1,K)-KOBS(1,K)+1 ENDIF ELSEIF(MOD(KOBS(1,K),2).NE.0) THEN IF(PROBS(1,K).EQ.'+') THEN KC(1,K)=NOBS(1,K)-KOBS(1,K)+1 ELSE KC(1,K)=NOBS(1,K)-KOBS(1,K) ENDIF ENDIF IF(MOD(KOBS(2,K),2).EQ.0) THEN IF(PROBS(2,K).EQ.'+') THEN KC(2,K)=NOBS(2,K)-KOBS(2,K) ELSE KC(2,K)=NOBS(2,K)-KOBS(2,K)+1 ENDIF ELSEIF(MOD(KOBS(2,K),2).NE.0) THEN IF(PROBS(2,K).EQ.'+') THEN KC(2,K)=NOBS(2,K)-KOBS(2,K)+1 ELSE KC(2,K)=NOBS(2,K)-KOBS(2,K) ENDIF ENDIF ELSE ccik debug change of rho sign KT1K=KOBS(1,K)*(-1)**IVOBS(1,K) c IF(KT1K.EQ.0.OR.KT1K.EQ.-1) THEN IF(KT1K.EQ.0.OR.KT1K.EQ.1) THEN KC(1,K)=NOBS(1,K) c ELSEIF(KT1K.EQ.1.OR.KT1K.EQ.-2) THEN ELSEIF(KT1K.EQ.-1.OR.KT1K.EQ.2) THEN KC(1,K)=NOBS(1,K)-1 c ELSEIF(KT1K.EQ.2.OR.KT1K.EQ.-3) THEN ELSEIF(KT1K.EQ.-2.OR.KT1K.EQ.3) THEN KC(1,K)=NOBS(1,K)-2 c ELSEIF(KT1K.EQ.3.OR.KT1K.EQ.-4) THEN ELSEIF(KT1K.EQ.-3.OR.KT1K.EQ.4) THEN KC(1,K)=NOBS(1,K)-3 cjth I changed the Kc labels below to be correct for CH3COOH c ELSEIF(KT1K.EQ.4.OR.KT1K.EQ.-5) THEN ELSEIF(KT1K.EQ.-4.OR.KT1K.EQ.5) THEN KC(1,K)=NOBS(1,K)-4 ELSEIF(KT1K.EQ.-5.OR.KT1K.EQ.6) THEN KC(1,K)=NOBS(1,K)-5 ELSEIF(KT1K.EQ.-6.OR.KT1K.EQ.7) THEN KC(1,K)=NOBS(1,K)-6 ELSEIF(KT1K.EQ.-7.OR.KT1K.EQ.8) THEN KC(1,K)=NOBS(1,K)-7 ELSEIF(KT1K.EQ.-8.OR.KT1K.EQ.9) THEN KC(1,K)=NOBS(1,K)-8 ELSEIF(KT1K.EQ.-9.OR.KT1K.EQ.10) THEN KC(1,K)=NOBS(1,K)-9 ELSEIF(KT1K.EQ.-10.OR.KT1K.EQ.11) THEN KC(1,K)=NOBS(1,K)-10 ELSEIF(KT1K.EQ.-11.OR.KT1K.EQ.12) THEN KC(1,K)=NOBS(1,K)-11 ELSEIF(KT1K.EQ.-12.OR.KT1K.EQ.13) THEN KC(1,K)=NOBS(1,K)-12 ELSEIF(KT1K.EQ.-13.OR.KT1K.EQ.14) THEN KC(1,K)=NOBS(1,K)-13 ELSEIF(KT1K.EQ.-14.OR.KT1K.EQ.15) THEN KC(1,K)=NOBS(1,K)-14 ELSEIF(KT1K.EQ.-15.OR.KT1K.EQ.16) THEN KC(1,K)=NOBS(1,K)-15 ENDIF KT2K=KOBS(2,K)*(-1)**IVOBS(2,K) c IF(KT2K.EQ.0.OR.KT2K.EQ.-1) THEN IF(KT2K.EQ.0.OR.KT2K.EQ.1) THEN KC(2,K)=NOBS(2,K) c ELSEIF(KT2K.EQ.1.OR.KT2K.EQ.-2) THEN ELSEIF(KT2K.EQ.-1.OR.KT2K.EQ.2) THEN KC(2,K)=NOBS(2,K)-1 ELSEIF(KT2K.EQ.-2.OR.KT2K.EQ.3) THEN KC(2,K)=NOBS(2,K)-2 ELSEIF(KT2K.EQ.-3.OR.KT2K.EQ.4) THEN KC(2,K)=NOBS(2,K)-3 cjth I changed the Kc labeling below to be correct for CH3COOH. ELSEIF(KT2K.EQ.-4.OR.KT2K.EQ.5) THEN KC(2,K)=NOBS(2,K)-4 ELSEIF(KT2K.EQ.-5.OR.KT2K.EQ.6) THEN KC(2,K)=NOBS(2,K)-5 ELSEIF(KT2K.EQ.-6.OR.KT2K.EQ.7) THEN KC(2,K)=NOBS(2,K)-6 ELSEIF(KT2K.EQ.-7.OR.KT2K.EQ.8) THEN KC(2,K)=NOBS(2,K)-7 ELSEIF(KT2K.EQ.-8.OR.KT2K.EQ.9) THEN KC(2,K)=NOBS(2,K)-8 ELSEIF(KT2K.EQ.-9.OR.KT2K.EQ.10) THEN KC(2,K)=NOBS(2,K)-9 ELSEIF(KT2K.EQ.-10.OR.KT2K.EQ.11) THEN KC(2,K)=NOBS(2,K)-10 ELSEIF(KT2K.EQ.-11.OR.KT2K.EQ.12) THEN KC(2,K)=NOBS(2,K)-11 ELSEIF(KT2K.EQ.-12.OR.KT2K.EQ.13) THEN KC(2,K)=NOBS(2,K)-12 ELSEIF(KT2K.EQ.-13.OR.KT2K.EQ.14) THEN KC(2,K)=NOBS(2,K)-13 ELSEIF(KT2K.EQ.-14.OR.KT2K.EQ.15) THEN KC(2,K)=NOBS(2,K)-14 ELSEIF(KT2K.EQ.-15.OR.KT2K.EQ.16) THEN KC(2,K)=NOBS(2,K)-15 ENDIF ENDIF 60 IF(IAST(K).EQ.1) THEN EOBS=ETRANS(K) TME2=EOBS-ECALC S=S+TME2**2*W(K) IF(IW(K).GE.1000) THEN WMW=WMW+TME2**2*W(K) SMW=SMW+TME2**2 cjth added some if's here to separate A and E stuff. if(k.le.nadat) then SWA=SWA+TME2**2 WMWA=WMWA+TME2**2*W(K) elseif(k.gt.nadat) then SWE=SWE+TME2**2 WMWE=WMWE+TME2**2*W(K) endif IF(IVOBS(1,K).EQ.0.AND.IW(K).GE.1000) THEN WMW0=WMW0+TME2**2*W(K) SMW0=SMW0+TME2**2 ELSEIF(IVOBS(1,K).EQ.1.AND.IW(K).GE.1000) THEN WMW1=WMW1+TME2**2*W(K) SMW1=SMW1+TME2**2 ELSEIF(IVOBS(1,K).EQ.2.AND.IW(K).GE.1000) THEN WMW2=WMW2+TME2**2*W(K) SMW2=SMW2+TME2**2 ELSEIF(IVOBS(1,K).EQ.3.AND.IW(K).GE.1000) THEN WMW3=WMW3+TME2**2*W(K) SMW3=SMW3+TME2**2 ELSEIF(IVOBS(1,K).EQ.4.AND.IW(K).GE.1000) THEN WMW4=WMW4+TME2**2*W(K) SMW4=SMW4+TME2**2 C ELSEIF(IW(K).EQ.2000) THEN C SWGOOD=SWGOOD+TME2**2*W(K) ENDIF IF(IW(K).EQ.1004.OR.IW(K).EQ.1005.OR.IW(K).EQ.1003) THEN WIG004=WIG004+TME2**2*W(K) SIG004=SIG004+TME2**2 ELSEIF(IW(K).EQ.1080) THEN WIG080=WIG080+TME2**2*W(K) SIG080=SIG080+TME2**2 ELSEIF(IW(K).EQ.1070) THEN WIG070=WIG070+TME2**2*W(K) SW070=SW070+TME2**2 ELSEIF(IW(K).EQ.1010.OR.IW(K).EQ.1008) THEN WIG010=WIG010+TME2**2*W(K) SIG010=SIG010+TME2**2 ELSEIF(IW(K).EQ.1100) THEN WIG100=WIG100+TME2**2*W(K) SIG100=SIG100+TME2**2 ELSEIF(IW(K).EQ.1020) THEN WIG020=WIG020+TME2**2*W(K) SIG020=SIG020+TME2**2 ELSEIF(IW(K).EQ.1200.OR.IW(K).EQ.1180.OR.IW(K).EQ.1160 & .OR.IW(K).EQ.1150.OR.IW(K).EQ.1130) THEN WIG200=WIG200+TME2**2*W(K) SIG200=SIG200+TME2**2 ELSEIF(IW(K).EQ.1030.OR.IW(K).EQ.1040.OR.IW(K).EQ.1050) & THEN WIG045=WIG045+TME2**2*W(K) SIG045=SIG045+TME2**2 ELSEIF(IW(K).EQ.1990) THEN WIG1M0=WIG1M0+TME2**2*W(K) SIG1M0=SIG1M0+TME2**2 ENDIF EOBS=EOBS*29979.2458 ECALC=ECALC*29979.2458 TME2=TME2*29979.2458 ELSEIF(IW(K).EQ.1) THEN WIR10=WIR10+TME2**2*W(K) SIR10=SIR10+TME2**2 WIR=WIR+TME2**2*W(K) SIR=SIR+TME2**2 ELSEIF(IW(K).EQ.2) THEN WIR21=WIR21+TME2**2*W(K) SIR21=SIR21+TME2**2 WIR=WIR+TME2**2*W(K) SIR=SIR+TME2**2 ELSEIF(IW(K).EQ.3) THEN WIR32=WIR32+TME2**2*W(K) SIR32=SIR32+TME2**2 WIR=WIR+TME2**2*W(K) SIR=SIR+TME2**2 ELSEIF(IW(K).EQ.10) THEN WGST0=WGST0+TME2**2*W(K) SGST0=SGST0+TME2**2 ENDIF C IF(IW(K).GE.1000) IW(K)=IW(K)-1000 C IF(IW(K).EQ.10) IW(K)=10000 C WRITE(6,604) IVOBS(2,K),NOBS(2,K),KOBS(2,K),KC(2,K) C 1 ,PROBS(2,K),IVOBS(1,K),NOBS(1,K),KOBS(1,K),KC(1,K), C 2 PROBS(1,K),EOBS,ECALC,TME2,IW(K),IAST(K),REF(K) C604 FORMAT(1X,I3,1X,I3,1X,I3,1X,I3,1X,A1,1X,I3,1X,I3,1X,I3, C 1 1X,I3,1X,A1,11X,F12.4,1X,F16.4,1X,F16.4,1X,I5,1X,I3,1X,A1) IF(IW(K).GE.1000) THEN IF(IW(K).EQ.2000) IW(K)=2 IF(IW(K).LT.2000) IW(K)=IW(K)-1000 C C HERE THE USER HAS THE CHOICE BETWEEN A COMPACT FORMAT (THE ONE C WHICH IS NOW PRECEDED BY "C" OR A LESS DENSE FORMAT C c IF(REF(K).NE.'NIST '.OR.REF(K).NE.'KHARK ') then ccjth I modified the write statement to print out E' and E". WRITE(6,604) IVOBS(2,K),NOBS(2,K),KOBS(2,K),KC(2,K) 1 ,PROBS(2,K),IVOBS(1,K),NOBS(1,K),KOBS(1,K),KC(1,K), cc 2 PROBS(1,K),EOBS,IW(K),ECALC,TME2,REF(K) 2 PROBS(1,K),EOBS,IW(K),ECALC,TME2,REF(K),EE(2),EE(1) if(tme2.ge.4.) print*,'attention!' c endif 604 FORMAT(1X,I3,1X,I3,1X,I3,1X,I3,1X,A1,1X,I3,1X,I3,1X,I3, 1 1X,I3,1X,A1,1X,F12.3,'(',I3,')',1X,F12.3,2X,F7.3, cc 2 1X,A6) 2 1X,A6,3X,2f13.8) C WRITE(6,604) IVOBS(2,K),NOBS(2,K),KOBS(2,K),KC(2,K) C 1 ,PROBS(2,K),IVOBS(1,K),NOBS(1,K),KOBS(1,K),KC(1,K), C 2 PROBS(1,K),EOBS,IW(K),ECALC,TME2,IAST(K),REF(K) C604 FORMAT(1X,I3,1X,I3,1X,I3,1X,I3,1X,A1,1X,I3,1X,I3,1X,I3, C 1 1X,I3,1X,A1,11X,F12.3,'(',I3,')',1X,F16.3,1X,F16.3,1X,I5, C 21X,A1) ELSEIF(IW(K).EQ.10) THEN IW(K)=5 c WRITE(6,634) IVOBS(2,K),NOBS(2,K),KOBS(2,K),KC(2,K) c 1 ,PROBS(2,K),IVOBS(1,K),NOBS(1,K),KOBS(1,K),KC(1,K), c 2 PROBS(1,K),EOBS,IW(K),ECALC,TME2,IAST(K),REF(K) c 3 ,EE(2),EE(1) 634 FORMAT(1X,I3,1X,I3,1X,I3,1X,I3,1X,A1,1X,I3,1X,I3,1X,I3, 1 1X,I3,1X,A1,11X,F12.4,'(',I1,')',1X,F16.4,1X,F16.4,1X,I5, 2 1X,A6,1X,F9.4,1X,F9.4) ELSEIF(IW(K).EQ.1) THEN IW(K)=4 C C HERE AGAIN THE USER CAN CHOICE A FORMAT C C WRITE(6,635) IVOBS(2,K),NOBS(2,K),KOBS(2,K),KC(2,K) C 1 ,PROBS(2,K),IVOBS(1,K),NOBS(1,K),KOBS(1,K),KC(1,K), C 2 PROBS(1,K),EOBS,IW(K),ECALC,TME2,IAST(K),REF(K) C635 FORMAT(1X,I3,1X,I3,1X,I3,1X,I3,1X,A1,1X,I3,1X,I3,1X,I3, C 1 1X,I3,1X,A1,11X,F12.4,'(',I1,')',1X,F16.4,1X,F16.4,1X,I5, C 21X,A1) cc WRITE(6,635) IVOBS(2,K),NOBS(2,K),KOBS(2,K),KC(2,K) c 1 ,PROBS(2,K),IVOBS(1,K),NOBS(1,K),KOBS(1,K),KC(1,K), c 2 PROBS(1,K),EOBS,IW(K),ECALC,TME2,REF(K),EE(2),EE(1) 635 FORMAT(1X,I3,1X,I3,1X,I3,1X,I3,1X,A1,1X,I3,1X,I3,1X,I3, 1 1X,I3,1X,A1,1X,F12.4,'(',I1,')',1X,F12.4,1X,F7.4, 2 1X,A6,1X,F9.4,1X,F9.4) ELSEIF(IW(K).EQ.2.OR.IW(K).EQ.3)THEN IW(K)=5 C C HERE AGAIN THE USER CAN CHOICE A FORMAT C C WRITE(6,635) IVOBS(2,K),NOBS(2,K),KOBS(2,K),KC(2,K) C 1 ,PROBS(2,K),IVOBS(1,K),NOBS(1,K),KOBS(1,K),KC(1,K), C 2 PROBS(1,K),EOBS,IW(K),ECALC,TME2,IAST(K),REF(K) cc WRITE(6,635) IVOBS(2,K),NOBS(2,K),KOBS(2,K),KC(2,K) cc 1 ,PROBS(2,K),IVOBS(1,K),NOBS(1,K),KOBS(1,K),KC(1,K), cc 2 PROBS(1,K),EOBS,IW(K),ECALC,TME2,REF(K),EE(2),EE(1) ENDIF ELSEIF(IAST(K).NE.1) THEN EOBS=ETRANS(K) TME3=EOBS-ECALC IF(IW(K).GE.1000) THEN IF(IW(K).LT.2000) IW(K)=IW(K)-1000 EOBS=EOBS*29979.2458 ECALC=ECALC*29979.2458 TME3=TME3*29979.2458 AST='*' ccjth I modified the write statement to get E' and E" printed out. WRITE(6,605) IVOBS(2,K),NOBS(2,K),KOBS(2,K),KC(2,K), 1 PROBS(2,K),IVOBS(1,K),NOBS(1,K),KOBS(1,K),KC(1,K), cc 2 PROBS(1,K),EOBS,IW(K),ECALC,TME3,AST,REF(K) 2 PROBS(1,K),EOBS,IW(K),ECALC,TME3,AST,REF(K),EE(2),EE(1) ELSE TME2=EOBS-ECALC AST='*' c WRITE(6,608) IVOBS(2,K),NOBS(2,K),KOBS(2,K),KC(2,K), c 1 PROBS(2,K),IVOBS(1,K),NOBS(1,K),KOBS(1,K),KC(1,K), c 2 PROBS(1,K),EOBS,ECALC,TME2,AST,REF(K),EE(2),EE(1) ENDIF C605 FORMAT(1X,I3,1X,I3,1X,I3,1X,I3,1X,A1,1X,I3,1X,I3,1X,I3,1X, C 1 I3,1X,A1,11X,F12.4,1X,F16.4,1X,F16.4,1X,A1,1X,A1) 605 FORMAT(1X,I3,1X,I3,1X,I3,1X,I3,1X,A1,1X,I3,1X,I3,1X,I3,1X, C*******FORMAT CHANGE JTH C 1 I3,1X,A1,1X,F12.3,1X,F12.3,1X,F7.3,1X,A1,1X,A1) 1 I3,1X,A1,1X,F12.3,'(',I3,')',1X,F12.3,2X,F7.3 cc 2 ,1X,A1,1X,A6) 2 ,1X,A1,1X,A6,1x,2f13.8) C605 FORMAT(1X,I3,1X,I3,1X,I3,1X,I3,1X,A1,1X,I3,1X,I3,1X,I3,1X, C 1 I3,1X,A1,11X,F12.3,1X,F16.3,1X,F16.3,1X,A1,1X,A1) 608 FORMAT(1X,I3,1X,I3,1X,I3,1X,I3,1X,A1,1X,I3,1X,I3,1X,I3,1X, 1 I3,1X,A1,11X,F12.4,1X,F16.4,1X,F16.4,1X,A1,1X,A6, 2 1X,F9.4,1X,F9.4) ENDIF 22 CONTINUE IF((NOFIT-NPP).LE.0) GO TO 23 S=SQRT(S/(NOFIT-NPP)) 23 IF(NFITMW.EQ.0) THEN WMW=0.0 SMW=0.0 ELSE WMW=SQRT(WMW/NFITMW) SMW=SQRT(SMW/NFITMW) ENDIF IF(NFITMWA.EQ.0) THEN WMWA=0.0 SWA=0.0 ELSE WMWA=SQRT(WMWA/NFITMWA) SWA=SQRT(SWA/NFITMWA) ENDIF IF(NFITMWE.EQ.0) THEN WMWE=0.0 SWE=0.0 ELSE WMWE=SQRT(WMWE/NFITMWE) SWE=SQRT(SWE/NFITMWE) ENDIF IF(NFITIR.EQ.0) THEN WIR=0.0 SIR=0.0 ELSE WIR=SQRT(WIR/NFITIR) SIR=SQRT(SIR/NFITIR) ENDIF IF(NFIR10.EQ.0) THEN WIR10=0.0 SIR10=0.0 ELSE WIR10=SQRT(WIR10/NFIR10) SIR10=SQRT(SIR10/NFIR10) ENDIF IF(NFIR21.EQ.0) THEN WIR21=0.0 SIR21=0.0 ELSE WIR21=SQRT(WIR21/NFIR21) SIR21=SQRT(SIR21/NFIR21) ENDIF IF(NFIR32.EQ.0) THEN WIR32=0.0 SIR32=0.0 ELSE WIR32=SQRT(WIR32/NFIR32) SIR32=SQRT(SIR32/NFIR32) ENDIF IF(NFIMW0 .EQ.0) THEN WMW0=0.0 SMW0=0.0 ELSE WMW0=SQRT(WMW0/NFIMW0 ) SMW0=SQRT(SMW0/NFIMW0 ) ENDIF IF(NFI070 .EQ.0) THEN SW070=0.0 WIG070=0.0 ELSE SW070=SQRT(SW070/NFI070 ) WIG070=SQRT(WIG070/NFI070 ) ENDIF IF(NFIMW1 .EQ.0) THEN WMW1=0.0 SMW1=0.0 ELSE WMW1=SQRT(WMW1/NFIMW1 ) SMW1=SQRT(SMW1/NFIMW1 ) ENDIF IF(NFIMW2.EQ.0) THEN WMW2=0. SMW2=0. ELSE WMW2=SQRT(WMW2/NFIMW2) SMW2=SQRT(SMW2/NFIMW2) ENDIF IF(NFIMW3.EQ.0) THEN WMW3=0. SMW3=0. ELSE WMW3=SQRT(WMW3/NFIMW3) SMW3=SQRT(SMW3/NFIMW3) ENDIF IF(NFIMW4.EQ.0) THEN WMW4=0. SMW4=0. ELSE WMW4=SQRT(WMW4/NFIMW4) SMW4=SQRT(SMW4/NFIMW4) ENDIF IF(NFI004 .EQ.0) THEN WIG004=0. SIG004=0. ELSE WIG004=SQRT(WIG004/NFI004 ) SIG004=SQRT(SIG004/NFI004 ) ENDIF IF(NFI080 .EQ.0) THEN WIG080=0.0 SIG080=0.0 ELSE WIG080=SQRT(WIG080/NFI080 ) SIG080=SQRT(SIG080/NFI080 ) ENDIF IF(NFI010 .EQ.0) THEN WIG010=0.0 SIG010=0.0 ELSE WIG010=SQRT(WIG010/NFI010 ) SIG010=SQRT(SIG010/NFI010 ) ENDIF IF(NFI100 .EQ.0) THEN WIG100=0.0 SIG100=0.0 ELSE WIG100=SQRT(WIG100/NFI100 ) SIG100=SQRT(SIG100/NFI100 ) ENDIF IF(NFI020 .EQ.0) THEN WIG020=0.0 SIG020=0.0 ELSE WIG020=SQRT(WIG020/NFI020 ) SIG020=SQRT(SIG020/NFI020 ) ENDIF IF(NFI200 .EQ.0) THEN WIG200=0.0 SIG200=0.0 ELSE WIG200=SQRT(WIG200/NFI200 ) SIG200=SQRT(SIG200/NFI200 ) ENDIF IF(NFI045 .EQ.0) THEN WIG045=0.0 SIG045=0.0 ELSE WIG045=SQRT(WIG045/NFI045 ) SIG045=SQRT(SIG045/NFI045 ) ENDIF IF(NFI1M0 .EQ.0) THEN WIG1M0=0.0 SIG1M0=0.0 ELSE WIG1M0=SQRT(WIG1M0/NFI1M0 ) SIG1M0=SQRT(SIG1M0/NFI1M0 ) ENDIF IF(NGST0.EQ.0) THEN WGST0=0. SGST0=0. ELSE WGST0=SQRT(WGST0/NGST0) SGST0=SQRT(SGST0/NGST0) ENDIF WRITE(6,900) S,NOFIT WRITE(6,901) WMW,NFITMW WRITE(6,801) WMWA,NFITMWA WRITE(6,802) WMWE,NFITMWE SMW0=SMW0*29979.2458 SMW1=SMW1*29979.2458 SMW2=SMW2*29979.2458 SMW3=SMW3*29979.2458 SMW4=SMW4*29979.2458 SWA=SWA*29979.2458 SWE=SWE*29979.2458 WRITE(6,903) WMW0,NFIMW0 WRITE(6,904) WMW1,NFIMW1 WRITE(6,700) WMW2,NFIMW2 WRITE(6,600) WMW3,NFIMW3 WRITE(6,500) WMW4,NFIMW4 WRITE(6,902) WIR,NFITIR WRITE(6,912) WIR10,NFIR10 WRITE(6,913) WIR21,NFIR21 WRITE(6,914) WIR32,NFIR32 WRITE(6,899) WGST0,NGST0 WRITE(6,920) WIG004,NFI004 WRITE(6,931) WIG010,NFI010 WRITE(6,933) WIG020,NFI020 WRITE(6,935) WIG045,NFI045 WRITE(6,936) WIG070,NFI070 WRITE(6,930) WIG080,NFI080 WRITE(6,932) WIG100,NFI100 WRITE(6,934) WIG200,NFI200 WRITE(6,937) WIG1M0,NFI1M0 C SIR=SIR*0.000353553 C SMW0=SMW0*0.078 C SMW1=SMW1*0.04 CCC=29979.2458 SIG004=SIG004*CCC SIG080=SIG080*CCC SIG010=SIG010*CCC SIG100=SIG100*CCC SIG020=SIG020*CCC SIG200=SIG200*CCC SIG045=SIG045*CCC SIG1M0=SIG1M0*CCC SW070=SW070*CCC C SGST0=SGST0*0.0005 WRITE(6,906) SMW0 WRITE(6,907) SMW1 WRITE(6,701) SMW2 WRITE(6,601) SMW3 WRITE(6,501) SMW4 WRITE(6,803) SWA WRITE(6,804) SWE WRITE(6,905) SIR WRITE(6,915) SIR10 WRITE(6,916) SIR21 WRITE(6,917) SIR32 WRITE(6,888) SGST0 WRITE(6,890) SIG004 WRITE(6,892) SIG010 WRITE(6,894) SIG020 WRITE(6,896) SIG045 WRITE(6,897) SW070 WRITE(6,891) SIG080 WRITE(6,893) SIG100 WRITE(6,895) SIG200 WRITE(6,898) SIG1M0 900 FORMAT(/,' STD.DEV.(UNITLESS) = ',F20.8,' NB.DATA= ',I4) 901 FORMAT(/,' RMS.DEV.MW(UNITLESS) = ',F20.4,2X,I4) 801 FORMAT(/,' RMS.DEV.MW TYPE A(UNITLESS)= ',F20.4,2X,I4) 802 FORMAT(/,' RMS.DEV.MW TYPE E(UNITLESS)= ',F20.4,2X,I4) 902 FORMAT(/,' RMS.DEV.IR(UNITLESS) = ',F20.6,2X,I4) 912 FORMAT(/,' RMS.DEV.IR(UNITLESS) V=1-0 = ',F20.6,2X,I4) 913 FORMAT(/,' RMS.DEV.IR(UNITLESS) V=2-1 = ',F20.6,2X,I4) 914 FORMAT(/,' RMS.DEV.IR(UNITLESS) V=3-2 = ',F20.6,2X,I4) 903 FORMAT(/,' RMS.DEV.MW(UNITLESS)VT=0 = ',F20.4,2X,I4) 904 FORMAT(/,' RMS.DEV.MW(UNITLESS)VT=1 = ',F20.4,2X,I4) 700 FORMAT(/,' RMS.DEV.MW(UNITLESS)VT=2 = ',F20.4,2X,I4) 600 FORMAT(/,' RMS.DEV.MW(UNITLESS)VT=3 = ',F20.4,2X,I4) 500 FORMAT(/,' RMS.DEV.MW(UNITLESS)VT=4 = ',F20.4,2X,I4) 899 FORMAT(/,' RMS.DEV.GROUND STATE DIFF. VT=0) = ',F20.4,2X,I4) 920 FORMAT(/,' STD.MW. W=0.003MHZ',F20.6,2X,I4) 930 FORMAT(/,' STD.MW. W=0.080MHZ',F20.6,2X,I4) 931 FORMAT(/,' STD.MW. W=0.010MHZ',F20.6,2X,I4) 932 FORMAT(/,' RMS.MW. W=0.100MHZ',F20.6,2X,I4) 933 FORMAT(/,' RMS.MW. W=0.020MHZ',F20.6,2X,I4) 934 FORMAT(/,' RMS.MW. W=0.200MHZ',F20.6,2X,I4) 935 FORMAT(/,' RMS.MW. W=0.045MHZ',F20.6,2X,I4) 936 FORMAT(/,' RMS.MW. W=0.070MHZ',F20.6,2X,I4) 937 FORMAT(/,' RMS.MW. W=1.000MHZ',F20.6,2X,I4) 905 FORMAT(/,' RMS.DEV.IR(CM-1) = ',F20.6) 915 FORMAT(/,' RMS.DEV.IR(CM-1) V=1-0 = ',F20.6) 916 FORMAT(/,' RMS.DEV.IR(CM-1) V=2-1 = ',F20.6) 917 FORMAT(/,' RMS.DEV.IR(CM-1) V=3-2 = ',F20.6) 906 FORMAT(/,' RMS.DEV.MICRONDE VT=0(MHZ)= ',F20.4) 907 FORMAT(/,' RMS.DEV.MICRONDE VT=1(MHZ)= ',F20.4) 701 FORMAT(/,' RMS.DEV.MICRONDE VT=2(MHZ)= ',F20.4) 601 FORMAT(/,' RMS.DEV.MICRONDE VT=3(MHZ)= ',F20.4) 501 FORMAT(/,' RMS.DEV.MICRONDE VT=4(MHZ)= ',F20.4) 803 FORMAT(/,' RMS.DEV.MICRONDE "A" (MHZ)= ',F20.4) 804 FORMAT(/,' RMS.DEV.MICRONDE "E" (MHZ)= ',F20.4) 888 FORMAT(/,' RMS.DEV.GROUND STATE DIFF.VT=0 (CM-1)) = ',F20.6) 890 FORMAT(/,' RMS.DEV.MICROWAVE,WEIGHT=0.003MHZ',F20.4,' MHZ') 891 FORMAT(/,' RMS.DEV.MICROWAVE,WEIGHT=0.080MHZ',F20.4,' MHZ') 892 FORMAT(/,' RMS.DEV.MICROWAVE,WEIGHT=0.010MHZ',F20.4,' MHZ') 893 FORMAT(/,' RMS.DEV.MICROWAVE,WEIGHT=0.100MHZ',F20.4,' MHZ') 894 FORMAT(/,' RMS.DEV.MICROWAVE,WEIGHT=0.020MHZ',F20.4,' MHZ') 895 FORMAT(/,' RMS.DEV.MICROWAVE,WEIGHT=0.200MHZ',F20.4,' MHZ') 896 FORMAT(/,' RMS.DEV.MICROWAVE,WEIGHT=0.045MHZ',F20.4,' MHZ') 897 FORMAT(/,' RMS.DEV.MICROWAVE,WEIGHT=0.070MHZ',F20.4,' MHZ') 898 FORMAT(/,' RMS.DEV.MICROWAVE,WEIGHT=1.000MHZ',F20.4,' MHZ') RETURN END C************************************************************* SUBROUTINE MATOU2(X,Z,M,N,MM,NN) IMPLICIT REAL*8 ( A-H,O-Z ) C C ****************************************************************** DIMENSION X(M,N),Z(M) 1004 FORMAT(/) 1003 FORMAT(4X,9F14.7) 1000 FORMAT(9(11X,I3)) 1002 FORMAT(I4,9F14.6) C IFLG=1 ILOWER=1 1 IUPPER=ILOWER+8 IF(IUPPER-NN)3,2,2 2 IUPPER=NN IFLG=0 3 WRITE(6,1000)(J,J=ILOWER,IUPPER) WRITE(6,1004) WRITE(6,1003) (Z(J),J=ILOWER,IUPPER) WRITE(6,1004) DO 4 I=1,MM 4 WRITE(6,1002)I,(X(I,J),J=ILOWER,IUPPER) WRITE(6,1004) IF(IFLG)5,6,5 5 ILOWER=ILOWER+9 GO TO 1 6 RETURN END C************************************************************ C************************************************************* SUBROUTINE MATOUT(X,M,N,MM,NN) IMPLICIT REAL*8 ( A-H,O-Z ) C C ****************************************************************** DIMENSION X(M,N) 1004 FORMAT(/) 1000 FORMAT(9(11X,I3)) 1002 FORMAT(I4,9F14.6) C IFLG=1 ILOWER=1 1 IUPPER=ILOWER+8 IF(IUPPER-NN)3,2,2 2 IUPPER=NN IFLG=0 3 WRITE(6,1000)(J,J=ILOWER,IUPPER) WRITE(6,1004) DO 4 I=1,MM WRITE(6,1002)I,(X(I,J),J=ILOWER,IUPPER) 4 CONTINUE WRITE(6,1004) IF(IFLG)5,6,5 5 ILOWER=ILOWER+9 GO TO 1 6 RETURN END C************************************************************ SUBROUTINE PARAM(I,CST) IMPLICIT REAL*8 ( A-H,O-Z ) C************************************************************ C READING OF THE PARAMETERS TO BE FITTED AND STORING THEM IN C X VECTOR(ONLY ONE VECTOR FOR THE 2 STATES) PARA(LO,L) C RETAINS WHICH PARAMETER C CHARACTER ABC*702 CHARACTER*6 PARA,REF CHARACTER*1 PR,PROBS COMMON/PAR/IND(2,80),NP(2),X(160),ITO COMMON/CHARA/PARA(2,160),PR,PROBS(2,80000),REF(80000) COMMON/SYMB/ABC DIMENSION CST(2,117) READ(5,20) NP(I) 20 FORMAT(I3) WRITE(6,*) ' NBRE OF PARAMETERS TO FIT ',NP(I) IF(NP(I).NE.0) THEN K=0 IF(I.EQ.2) K=NP(1) WRITE(6,*) ' PARAMETER TO BE FIT ' DO 2 J=1,NP(I) IF(I.EQ.2.AND.NP(1).NE.0) THEN JJ=J+NP(1) ELSE JJ=J ENDIF READ(5,'(A6)') PARA(I,JJ) WRITE(6,*) ' PARA = ',PARA(I,JJ) IK=IREP(PARA(I,JJ)) IND(I,J)=IK X(K+J)=CST(I,IK) 2 CONTINUE ENDIF C PRINT*,' NP(1)',NP(1),' NP(2)= ',NP(2) RETURN END SUBROUTINE REJEC(REJ) IMPLICIT REAL*8 ( A-H,O-Z ) C C THIS SUBROUTINE REJECTS AN EXPERIMENTAL VALUE IF THE C CORRESPONDING TME IS GREATER THAN 3*SIGMA (S). C not used in the present version. C ********************************************************* CHARACTER*6 PARA,REF CHARACTER*1 PR,PROBS INTEGER REJ COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRON1 , * IBGTME,IBGVTD ,EVIB(2),IRMW,TERM COMMON/PAR/IND(2,80),NP(2),X(160),ITO COMMON/EXPDAT / ETRANS(80000),IVOBS(2,80000), * NOBS(2,80000),KOBS(2,80000),IBLK(2,80000),IW(80000),W(80000), * NDATA,NADAT,EPSI,NOFIT,NFITMW,NFITIR,NFIMW0 ,NFIMW1 ,NITT, * IAST(80000),NFI004 ,NFI080 ,NFI100 ,NFI020 ,NFI200 ,NFI045 , & NGST0 ,NFI010 ,SW070,NFI070 ,NFIMW2,IKAKC,JMAX,NFI1M0, & NFIR10,NFIR21,NFIR32,NFIMW3,NFIMW4,SWA,SWE,NFITMWA,NFITMWE COMMON/CNTL/NIT,IEND,DELTAS,S,TME(80000),TERMST,NP12,SMW,SIR, 1 SMW0,SMW1,SIG004,SIG080,SIG10,SIG100,SIG020,SIG200,SIG045, & SGST0,SMW2,SIG1M0,SMW3,SIG32,SMW4 COMMON/QUANT/ISIG,IV,N,KK COMMON/CHARA/PARA(2,160),PR,PROBS(2,80000),REF(80000) C REJLIM = 3*S WRITE(6,803) REJLIM IREJL = 10000 * REJLIM DO 88 I = 1, NDATA IF (IAST(I) .EQ. 0) THEN ITME = 10000 * ABS(TME(I)) IF (ITME .GT. IREJL) THEN IAST(I) = 2 WRITE(6,800) I,ETRANS(I) REJ = 1 END IF END IF 88 CONTINUE 800 FORMAT(' LINE NO ',I5,' AT',F14.4,' HAS BEEN REJECTED') 803 FORMAT(' THE REJECTION LIMIT IS ',F10.4) RETURN END C*********************************************************** SUBROUTINE RESUM1(LO,EGVL) IMPLICIT REAL*8 ( A-H,O-Z ) C********************************************************** C WRITES THE ENERGIES OF TORSION LEVELS C C CHARACTER*1 PR,PROBS CHARACTER*6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1) COMMON/QUANT/ISIG,IV,N,KK COMMON/CHARA/PARA(2,160),PR,PROBS(2,80000),REF(80000) COMMON/ROTOR/NROTOR,NDIMTO DIMENSION CST(2,117),EGVL(NDMX) DO 1 I=1,NDIMTO WRITE(6,53) I-1,EGVL(I) 53 FORMAT(/,' VT= ',I3,' E= ',F16.10,' CM-1') 1 CONTINUE RETURN END C*********************************************************** SUBROUTINE RESUM2(LO,EGVL,EGVC) IMPLICIT REAL*8 ( A-H,O-Z ) C*********************************************************** C WRITES THE ENERGIES OF THE ROTATION-TORSION LEVELS(E STATES) C CHARACTER*1 PUR(3*(2*(30)+1)) CHARACTER*1 PR,PROBS CHARACTER*6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1) COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRON1 , * IBGTME,IBGVTD ,EVIB(2),IRMW,TERM COMMON/QUANT/ISIG,IV,N,KK COMMON/CHARA/PARA(2,160),PR,PROBS(2,80000),REF(80000) DIMENSION IPST(3*(2*(30)+1)),EGVL(NDMX),EGVC(NDMX,NDMX) WRITE(6,*)' N= ',N,' ISIG= ',ISIG WRITE(6,50) 50 FORMAT(/,' TYPE E ',/) NN=2*N+1 NNT=NN*4 DO 1 J=1,NNT CST=0.0 DO 2 I=1,NNT C=EGVC(I,J)**2 IF(C.GT.CST) THEN CST=C IPST(J)=I ENDIF 2 CONTINUE C TEST THE PURITY PUR(J)=' ' DO 4 K=1,NNT IF(K.EQ.IPST(J)) GO TO 4 CC=EGVC(K,J)**2 IF(CC.GE.(CST*0.7D0)) THEN PUR(J)='*' GO TO 5 ENDIF 4 CONTINUE 5 IVT=0 DO 3 KKK=1,(04) IN=NN*KKK IF (IPST(J).GT.IN) IVT=IVT+1 3 CONTINUE K=IPST(J)-(N+1)-IVT*NN EGVL(J)=EGVL(J)+EVIB(LO) WRITE(6,55) IVT,K,EGVL(J),N,PUR(J) WRITE(LO+32,55) IVT,K,EGVL(J),N,PUR(J) 55 FORMAT (' VT= ',I3,' K= ',I3,' E= ',F16.10,' CM-1 ',' N= ',I3, & ' PURITY= ',A1) 1 CONTINUE RETURN END C************************************************************* SUBROUTINE RESUM3(LO,EGVL,EGVC) IMPLICIT REAL*8 ( A-H,O-Z ) C************************************************************** C WRITES THE ENERGIES OF THE ROT-TORSION LEVELS (A STATES) C CHARACTER PAR*1 CHARACTER*1 PR,PROBS CHARACTER*6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1) COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRON1 , * IBGTME,IBGVTD ,EVIB(2),IRMW,TERM COMMON/QUANT/ISIG,IV,N,KK COMMON/CHARA/PARA(2,160),PR,PROBS(2,80000),REF(80000) DIMENSION EGVL(NDMX),EGVC(NDMX,NDMX) WRITE(6,*) ' N= ',N,' ISIG= ',ISIG WRITE(6,50) 50 FORMAT(/,' TYPE A ',/) NN=2*N+1 NNT=NN*4 DO 1 J=1,NNT IVT=0 DO 3 KKK=1,(04) IN=NN*KKK IF (J.GT.IN) IVT=IVT+1 3 CONTINUE K=(N*J+N-IVT*N*NN)/NN IF (K.EQ.0) THEN PAR= '+' ELSE IF (MOD(K,2).NE.0) THEN IF(MOD(IVT,2).EQ.0) THEN IF(MOD(J,2).EQ.0) THEN PAR='+' ELSE PAR='-' ENDIF ELSE IF(MOD(J,2).EQ.0) THEN PAR='-' ELSE PAR='+' ENDIF ENDIF ELSE IF(MOD(K,2).EQ.0) THEN IF(MOD(IVT,2).EQ.0) THEN IF(MOD(J,2).EQ.0) THEN PAR='-' ELSE PAR='+' ENDIF ELSE IF(MOD(J,2).EQ.0) THEN PAR='+' ELSE PAR='-' ENDIF ENDIF ENDIF EGVL(J)=EGVL(J)+EVIB(LO) WRITE(6,56) IVT,K,EGVL(J),N,PAR WRITE(LO+30,56) IVT,K,EGVL(J),N,PAR 56 FORMAT (' VT= ',I3,' K= ',I3,' E= ',F16.10,' CM-1 ',' N= ',I3, & ' PAR= ',A1) 1 CONTINUE RETURN END SUBROUTINE ROTTOR(CST,LO,EGVL,EGVC,ETOR,A,nitt) IMPLICIT REAL*8 ( A-H,O-Z ) C*********************************************************** C CALCULATES THE ENERGIES OF LEVELS AND TRANSITIONS FOR EACH C N,LO BLOCK.SAME SUBROUTINE AS THE ROTOR PROGRAM C C CHARACTER ABC*702 CHARACTER*1 PR,PROBS CHARACTER*6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1) COMMON/EIGEN/H(NDMX,NDMX),WORK(NDMX),EGVC3(KDMX,9),NBR(2) COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRON1 , * IBGTME,IBGVTD ,EVIB(2),IRMW,TERM COMMON/ROTOR/NROTOR,NDIMTO COMMON/SYMB/ABC COMMON/QUANT/ISIG,IV,N,KK COMMON/QUANT2/KKK(NDMX),NVT(NDMX),IPRITY(NDMX) COMMON/C2C/PERC2L,PER23L(NDMX) COMMON/CHARA/PARA(2,160),PR,PROBS(2,80000),REF(80000) DIMENSION CST(2,117),UNIT(160,160),WKSPCE(160),EGVL(NDMX) DIMENSION EGVC(NDMX,NDMX),ETOR(KDMX,9),A(9,NTORMX,KDMX) DIMENSION EGVC4(KDMX,NTORMX,NDMX) dimension oldegv(ndmx,ndmx),oldegv1(ndmx,ndmx) dimension oldegv2(ndmx,ndmx),oldegv3(ndmx,ndmx) real*8 sum123(0:8),evect(ndmx),sum1(9) integer irespos(1) C KTRON1 =KTRONC+1 NDIMTO =2*KTRONC+1 if(nitt.eq.0)then jmax=20 c overlaps for torsional eigen functions if(n.eq.0.and.isig.eq.0)then c open(unit=13,file='ators.txt',access='sequential',status='unknown') c overlaps for A-type levels DO K1=0,jmax k=-k1 CALL HTORSE (K,CST,LO) CALL TRED2(NDIMTO,NDMX,H,EGVL,WORK,EGVC) CALL TQL2(NDIMTO,NDMX,EGVL,WORK,EGVC,IERR) c cycle over eigenvalues for a given k value do iji=1,ndimto evect=0.d0 c torsional energy c write(13,1924)k,egvl(iji),iji,isig do iki=1,ndimto evect(iki)=egvc(iki,iji)**2 enddo c cycle over 2 maximum values of components do iki=1,2 irespos = MAXLOC(evect) c write(13,1916)irespos(1),evect(irespos(1)) evect(irespos(1))=0.d0 enddo c mixing ratio with the same J c for A-type calculate mixing ratio with the same pr23l evect=0.d0 c cycle over all eigen vectors for previous N do i=1,ndimto if(i.eq.iji)cycle c calculating of overlap integral do iki=1,nrotor evect(i)=evect(i)+dabs(egvc(iki,iji)*egvc(iki,i)) enddo enddo irespos = MAXLOC(evect) c write(13,1916)irespos(1),evect(irespos(1)) c overlap integrals with previous K evect=0.d0 if(k.lt.0)then c cycle over all eigen vectors for previous N do i=1,ndimto c calculating of overlap integral do iki=1,ndimto evect(i)=evect(i)+egvc(iki,iji)*oldegv(iki,i) enddo evect(i)=dabs(evect(i)) enddo endif c output two largest overlap integrals c cycle over 2 maximum values of components do iki=1,2 irespos = MAXLOC(evect) c write(13,1916)irespos(1),evect(irespos(1)) evect(irespos(1))=0.d0 enddo c overlap integrals with J-2 evect=0.d0 if(k.lt.-1)then c cycle over all eigen vectors for N-2 do i=1,ndimto c calculating of overlap integral do iki=1,ndimto evect(i)=evect(i)+egvc(iki,iji)*oldegv1(iki,i) enddo evect(i)=dabs(evect(i)) enddo endif c output largest overlap integrals c cycle over 2 maximum values of components do iki=1,2 irespos = MAXLOC(evect) c write(13,1916)irespos(1),evect(irespos(1)) evect(irespos(1))=0.d0 enddo c overlap integrals with J-3 evect=0.d0 if(k.lt.-2)then c cycle over all eigen vectors for N-2 do i=1,ndimto c calculating of overlap integral do iki=1,ndimto evect(i)=evect(i)+egvc(iki,iji)*oldegv2(iki,i) enddo evect(i)=dabs(evect(i)) enddo endif c output largest overlap integrals c cycle over 2 maximum values of components do iki=1,2 irespos = MAXLOC(evect) c write(13,1916)irespos(1),evect(irespos(1)) evect(irespos(1))=0.d0 enddo c overlap integrals with J-4 evect=0.d0 if(k.lt.-3)then c cycle over all eigen vectors for N-2 do i=1,ndimto c calculating of overlap integral do iki=1,ndimto evect(i)=evect(i)+egvc(iki,iji)*oldegv3(iki,i) enddo evect(i)=dabs(evect(i)) enddo endif c output largest overlap integrals c cycle over 2 maximum values of components do iki=1,2 irespos = MAXLOC(evect) c write(13,1916)irespos(1),evect(irespos(1)) evect(irespos(1))=0.d0 enddo write(13,1917) enddo if(k.lt.-2)then c clean the store for n-4 eigen vectors and put there new ones oldegv3=0.d0 do j=1,ndimto do iji=1,ndimto oldegv3(iji,j)=oldegv2(iji,j) enddo enddo endif if(k.lt.-1)then c clean the store for n-3 eigen vectors and put there new ones oldegv2=0.d0 do j=1,ndimto do iji=1,ndimto oldegv2(iji,j)=oldegv1(iji,j) enddo enddo endif if(k.lt.0)then c clean the store for n-2 eigen vectors and put there new ones oldegv1=0.d0 do j=1,ndimto do iji=1,ndimto oldegv1(iji,j)=oldegv(iji,j) enddo enddo endif c clean the store for n-1 eigen vectors and put there new ones oldegv=0.d0 do j=1,ndimto do iji=1,ndimto oldegv(iji,j)=egvc(iji,j) enddo enddo 1924 format(1x,I6,F15.8,I4,I4,$) enddo DO K=0,jmax CALL HTORSE (K,CST,LO) CALL TRED2(NDIMTO,NDMX,H,EGVL,WORK,EGVC) CALL TQL2(NDIMTO,NDMX,EGVL,WORK,EGVC,IERR) c cycle over eigenvalues for a given k value do iji=1,ndimto evect=0.d0 c torsional energy write(13,1924)k,egvl(iji),iji,isig do iki=1,ndimto evect(iki)=egvc(iki,iji)**2 enddo c cycle over 2 maximum values of components do iki=1,2 irespos = MAXLOC(evect) c write(13,1916)irespos(1),evect(irespos(1)) evect(irespos(1))=0.d0 enddo c mixing ratio with the same J c for A-type calculate mixing ratio with the same pr23l evect=0.d0 c cycle over all eigen vectors for previous N do i=1,ndimto if(i.eq.iji)cycle c calculating of overlap integral do iki=1,nrotor evect(i)=evect(i)+dabs(egvc(iki,iji)*egvc(iki,i)) enddo enddo irespos = MAXLOC(evect) write(13,1916)irespos(1),evect(irespos(1)) c overlap integrals with previous K evect=0.d0 if(k.gt.0)then c cycle over all eigen vectors for previous N do i=1,ndimto c calculating of overlap integral do iki=1,ndimto evect(i)=evect(i)+egvc(iki,iji)*oldegv(iki,i) enddo evect(i)=dabs(evect(i)) enddo endif c output two largest overlap integrals c cycle over 2 maximum values of components do iki=1,2 irespos = MAXLOC(evect) c write(13,1916)irespos(1),evect(irespos(1)) evect(irespos(1))=0.d0 enddo c overlap integrals with J-2 evect=0.d0 if(k.gt.1)then c cycle over all eigen vectors for N-2 do i=1,ndimto c calculating of overlap integral do iki=1,ndimto evect(i)=evect(i)+egvc(iki,iji)*oldegv1(iki,i) enddo evect(i)=dabs(evect(i)) enddo endif c output largest overlap integrals c cycle over 2 maximum values of components do iki=1,2 irespos = MAXLOC(evect) c write(13,1916)irespos(1),evect(irespos(1)) evect(irespos(1))=0.d0 enddo c overlap integrals with J-3 evect=0.d0 if(k.gt.2)then c cycle over all eigen vectors for N-2 do i=1,ndimto c calculating of overlap integral do iki=1,ndimto evect(i)=evect(i)+egvc(iki,iji)*oldegv2(iki,i) enddo evect(i)=dabs(evect(i)) enddo endif c output largest overlap integrals c cycle over 2 maximum values of components do iki=1,2 irespos = MAXLOC(evect) c write(13,1916)irespos(1),evect(irespos(1)) evect(irespos(1))=0.d0 enddo c overlap integrals with J-4 evect=0.d0 if(k.gt.3)then c cycle over all eigen vectors for N-2 do i=1,ndimto c calculating of overlap integral do iki=1,ndimto evect(i)=evect(i)+egvc(iki,iji)*oldegv3(iki,i) enddo evect(i)=dabs(evect(i)) enddo endif c output largest overlap integrals c cycle over 2 maximum values of components do iki=1,2 irespos = MAXLOC(evect) c write(13,1916)irespos(1),evect(irespos(1)) evect(irespos(1))=0.d0 enddo c write(13,1917) enddo if(k.gt.2)then c clean the store for n-4 eigen vectors and put there new ones oldegv3=0.d0 do j=1,ndimto do iji=1,ndimto oldegv3(iji,j)=oldegv2(iji,j) enddo enddo endif if(k.gt.1)then c clean the store for n-3 eigen vectors and put there new ones oldegv2=0.d0 do j=1,ndimto do iji=1,ndimto oldegv2(iji,j)=oldegv1(iji,j) enddo enddo endif if(k.gt.0)then c clean the store for n-2 eigen vectors and put there new ones oldegv1=0.d0 do j=1,ndimto do iji=1,ndimto oldegv1(iji,j)=oldegv(iji,j) enddo enddo endif c clean the store for n-1 eigen vectors and put there new ones oldegv=0.d0 do j=1,ndimto do iji=1,ndimto oldegv(iji,j)=egvc(iji,j) enddo enddo enddo c close(13) endif if(n.eq.0.and.isig.eq.1)then c open(unit=14,file='etors.txt',access='sequential',status='unknown') c overlaps for E-type levels DO K1=0,jmax k=-k1 CALL HTORSE (K,CST,LO) CALL TRED2(NDIMTO,NDMX,H,EGVL,WORK,EGVC) CALL TQL2(NDIMTO,NDMX,EGVL,WORK,EGVC,IERR) c cycle over eigenvalues for a given k value do iji=1,ndimto evect=0.d0 c torsional energy c write(14,1924)k,egvl(iji),iji,isig do iki=1,ndimto evect(iki)=egvc(iki,iji)**2 enddo c cycle over 2 maximum values of components do iki=1,2 irespos = MAXLOC(evect) c write(14,1916)irespos(1),evect(irespos(1)) evect(irespos(1))=0.d0 enddo c mixing ratio with the same J c for A-type calculate mixing ratio with the same pr23l evect=0.d0 c cycle over all eigen vectors for previous N do i=1,ndimto if(i.eq.iji)cycle c calculating of overlap integral do iki=1,nrotor evect(i)=evect(i)+dabs(egvc(iki,iji)*egvc(iki,i)) enddo enddo irespos = MAXLOC(evect) c write(14,1916)irespos(1),evect(irespos(1)) c overlap integrals with previous K evect=0.d0 if(k.lt.0)then c cycle over all eigen vectors for previous N do i=1,ndimto c calculating of overlap integral do iki=1,ndimto evect(i)=evect(i)+egvc(iki,iji)*oldegv(iki,i) enddo evect(i)=dabs(evect(i)) enddo endif c output two largest overlap integrals c cycle over 2 maximum values of components do iki=1,2 irespos = MAXLOC(evect) c write(14,1916)irespos(1),evect(irespos(1)) evect(irespos(1))=0.d0 enddo c overlap integrals with J-2 evect=0.d0 if(k.lt.-1)then c cycle over all eigen vectors for N-2 do i=1,ndimto c calculating of overlap integral do iki=1,ndimto evect(i)=evect(i)+egvc(iki,iji)*oldegv1(iki,i) enddo evect(i)=dabs(evect(i)) enddo endif c output largest overlap integrals c cycle over 2 maximum values of components do iki=1,2 irespos = MAXLOC(evect) c write(14,1916)irespos(1),evect(irespos(1)) evect(irespos(1))=0.d0 enddo c overlap integrals with J-3 evect=0.d0 if(k.lt.-2)then c cycle over all eigen vectors for N-2 do i=1,ndimto c calculating of overlap integral do iki=1,ndimto evect(i)=evect(i)+egvc(iki,iji)*oldegv2(iki,i) enddo evect(i)=dabs(evect(i)) enddo endif c output largest overlap integrals c cycle over 2 maximum values of components do iki=1,2 irespos = MAXLOC(evect) c write(14,1916)irespos(1),evect(irespos(1)) evect(irespos(1))=0.d0 enddo c overlap integrals with J-4 evect=0.d0 if(k.lt.-3)then c cycle over all eigen vectors for N-2 do i=1,ndimto c calculating of overlap integral do iki=1,ndimto evect(i)=evect(i)+egvc(iki,iji)*oldegv3(iki,i) enddo evect(i)=dabs(evect(i)) enddo endif c output largest overlap integrals c cycle over 2 maximum values of components do iki=1,2 irespos = MAXLOC(evect) c write(14,1916)irespos(1),evect(irespos(1)) evect(irespos(1))=0.d0 enddo c write(14,1917) enddo if(k.lt.-2)then c clean the store for n-4 eigen vectors and put there new ones oldegv3=0.d0 do j=1,ndimto do iji=1,ndimto oldegv3(iji,j)=oldegv2(iji,j) enddo enddo endif if(k.lt.-1)then c clean the store for n-3 eigen vectors and put there new ones oldegv2=0.d0 do j=1,ndimto do iji=1,ndimto oldegv2(iji,j)=oldegv1(iji,j) enddo enddo endif if(k.lt.0)then c clean the store for n-2 eigen vectors and put there new ones oldegv1=0.d0 do j=1,ndimto do iji=1,ndimto oldegv1(iji,j)=oldegv(iji,j) enddo enddo endif c clean the store for n-1 eigen vectors and put there new ones oldegv=0.d0 do j=1,ndimto do iji=1,ndimto oldegv(iji,j)=egvc(iji,j) enddo enddo enddo DO K=0,jmax CALL HTORSE (K,CST,LO) CALL TRED2(NDIMTO,NDMX,H,EGVL,WORK,EGVC) CALL TQL2(NDIMTO,NDMX,EGVL,WORK,EGVC,IERR) c cycle over eigenvalues for a given k value do iji=1,ndimto evect=0.d0 c torsional energy c write(14,1924)k,egvl(iji),iji,isig do iki=1,ndimto evect(iki)=egvc(iki,iji)**2 enddo c cycle over 2 maximum values of components do iki=1,2 irespos = MAXLOC(evect) c write(14,1916)irespos(1),evect(irespos(1)) evect(irespos(1))=0.d0 enddo c mixing ratio with the same J c for A-type calculate mixing ratio with the same pr23l evect=0.d0 c cycle over all eigen vectors for previous N do i=1,ndimto if(i.eq.iji)cycle c calculating of overlap integral do iki=1,nrotor evect(i)=evect(i)+dabs(egvc(iki,iji)*egvc(iki,i)) enddo enddo irespos = MAXLOC(evect) c write(14,1916)irespos(1),evect(irespos(1)) c overlap integrals with previous K evect=0.d0 if(k.gt.0)then c cycle over all eigen vectors for previous N do i=1,ndimto c calculating of overlap integral do iki=1,ndimto evect(i)=evect(i)+egvc(iki,iji)*oldegv(iki,i) enddo evect(i)=dabs(evect(i)) enddo endif c output two largest overlap integrals c cycle over 2 maximum values of components do iki=1,2 irespos = MAXLOC(evect) c write(14,1916)irespos(1),evect(irespos(1)) evect(irespos(1))=0.d0 enddo c overlap integrals with J-2 evect=0.d0 if(k.gt.1)then c cycle over all eigen vectors for N-2 do i=1,ndimto c calculating of overlap integral do iki=1,ndimto evect(i)=evect(i)+egvc(iki,iji)*oldegv1(iki,i) enddo evect(i)=dabs(evect(i)) enddo endif c output largest overlap integrals c cycle over 2 maximum values of components do iki=1,2 irespos = MAXLOC(evect) c write(14,1916)irespos(1),evect(irespos(1)) evect(irespos(1))=0.d0 enddo c overlap integrals with J-3 evect=0.d0 if(k.gt.2)then c cycle over all eigen vectors for N-2 do i=1,ndimto c calculating of overlap integral do iki=1,ndimto evect(i)=evect(i)+egvc(iki,iji)*oldegv2(iki,i) enddo evect(i)=dabs(evect(i)) enddo endif c output largest overlap integrals c cycle over 2 maximum values of components do iki=1,2 irespos = MAXLOC(evect) c write(14,1916)irespos(1),evect(irespos(1)) evect(irespos(1))=0.d0 enddo c overlap integrals with J-4 evect=0.d0 if(k.gt.3)then c cycle over all eigen vectors for N-2 do i=1,ndimto c calculating of overlap integral do iki=1,ndimto evect(i)=evect(i)+egvc(iki,iji)*oldegv3(iki,i) enddo evect(i)=dabs(evect(i)) enddo endif c output largest overlap integrals c cycle over 2 maximum values of components do iki=1,2 irespos = MAXLOC(evect) c write(14,1916)irespos(1),evect(irespos(1)) evect(irespos(1))=0.d0 enddo c write(14,1917) enddo if(k.gt.2)then c clean the store for n-4 eigen vectors and put there new ones oldegv3=0.d0 do j=1,ndimto do iji=1,ndimto oldegv3(iji,j)=oldegv2(iji,j) enddo enddo endif if(k.gt.1)then c clean the store for n-3 eigen vectors and put there new ones oldegv2=0.d0 do j=1,ndimto do iji=1,ndimto oldegv2(iji,j)=oldegv1(iji,j) enddo enddo endif if(k.gt.0)then c clean the store for n-2 eigen vectors and put there new ones oldegv1=0.d0 do j=1,ndimto do iji=1,ndimto oldegv1(iji,j)=oldegv(iji,j) enddo enddo endif c clean the store for n-1 eigen vectors and put there new ones oldegv=0.d0 do j=1,ndimto do iji=1,ndimto oldegv(iji,j)=egvc(iji,j) enddo enddo enddo c close(14) endif endif C NDIMTOR:DEFFECTIVE DIMENSION OF THE TORSION MATRIX C PRINT*,' KTRONC1= ',KTRONC1,' NDIMTOR= ',NDIMTOR IF (NDIMTO .GT.NTORMX) THEN WRITE(6,*) ' DIMENSION NTORMX TOO LOW ' STOP ENDIF DO 2 K=-N,N IF(IBUG1.NE.0) WRITE(6,60) ISIG,K CALL HTORSE (K,CST,LO) 60 FORMAT(/,' SIGMA= ',I3,' K= ',I3,/) IF (IBUG1.NE.0) THEN WRITE(6,63) 63 FORMAT(/,' TORSION MATRIX TO BE DIAGONALISED',/) CALL MATOUT(H,NDMX,NDMX,NDIMTO ,NDIMTO ) ENDIF C C PERFORMS DIAGONALISATION(CRAY SUBROUTINES) C c CALL TRED2(NDMX,NDIMTO,H,EGVL,WORK,EGVC) c CALL TQL2(NDMX,NDIMTO ,EGVL,WORK,EGVC,IERR) c my insertion CALL TRED2(NDIMTO,NDMX,H,EGVL,WORK,EGVC) CALL TQL2(NDIMTO,NDMX,EGVL,WORK,EGVC,IERR) IF (IERR.NE.0) THEN WRITE(6,62) 62 FORMAT(/,' DIAGONALISATION FAILED FOR TORSION ',/) STOP ENDIF IF(IBUG1.NE.0) WRITE(6,81) 81 FORMAT(//,' TORSION EIGENVALUES AND EIGENVECTORS ',//) IF (IBUG1.NE.0) THEN CALL MATOU2 (EGVC,EGVL,NDMX,NDMX,NDIMTO ,NDIMTO ) ENDIF IF(IBUG1.NE.0) CALL RESUM1(LO,EGVL) C C STOCKS THE EIGENVECTORS IN A 3-DIMENSION MATRIX A C CALL ASET(K,EGVL,EGVC,ETOR,A) C C END OF THE LOOP ON K C 2 CONTINUE IF(IBUG2.NE.0) WRITE(6,70) ISIG,N 70 FORMAT(/,' SIGMA= ',I3,' N= ',I3,/) NROTOR=(2*N+1)*9 C PRINT*,'NROTOR=',NROTOR CALL HRTSET(CST,LO,ETOR,A) IF (IBUG2.NE.0) THEN WRITE(6,73) 73 FORMAT(/,' ROTATION-TORSION MATRIX TO BE 1 DIAGONALISED ',/) CALL MATOUT(H,NDMX,NDMX,NROTOR,NROTOR) ENDIF C C PERFORMS DIAGONALISATION C c CALL TRED2(NDMX,NROTOR,H,EGVL,WORK,EGVC) c CALL TQL2(NDMX,NROTOR,EGVL,WORK,EGVC,IERR) CALL TRED2(NROTOR,NDMX,H,EGVL,WORK,EGVC) CALL TQL2(NROTOR,NDMX,EGVL,WORK,EGVC,IERR) if(nitt.eq.0)then c output of expectation values for A-type levels IF(ISIG.EQ.0) THEN DO J=1,NROTOR IVTORP=1 DO I=1,NROTOR IU=(2*N+1)*IVTORP+1 IF(I.EQ.IU)IVTORP=IVTORP+1 II=I-(2*N+1)*(IVTORP-1) EGVC4(II,IVTORP,J)=EGVC(I,J) enddo CALL PARITY(A,EGVC4,J) enddo c cycle over eigenvalues for a given J value do iji=1,nrotor evect=0.d0 c reduced energy redener=egvl(iji)-cst(lo,2)*n*(n+1) c write(11,1914)redener,n*(n+1),n,egvl(iji),iji,per23l(iji) iki=0 do ikvt=0,8 icentr=n+1+(2*n+1)*ikvt do ikij=0,n iki=iki+1 if(ikij.eq.0)then evect(iki)=egvc(icentr,iji)**2 else evect(iki)=egvc(icentr+ikij,iji)**2+egvc(icentr-ikij,iji)**2 endif enddo enddo c cycle over 2 maximum values of components do iki=1,2 irespos = MAXLOC(evect) c write(11,1916)irespos(1),evect(irespos(1)) evect(irespos(1))=0.d0 enddo c mixing ratio with the same J c for A-type calculate mixing ratio with the same pr23l evect=0.d0 c cycle over all eigen vectors for previous N do i=1,nrotor if(i.eq.iji)cycle if(per23l(iji)*per23l(i).lt.0.d0)cycle c calculating of overlap integral do iki=1,nrotor evect(i)=evect(i)+dabs(egvc(iki,iji)*egvc(iki,i)) enddo enddo irespos = MAXLOC(evect) c write(11,1916)irespos(1),evect(irespos(1)) c overlap integrals with previous J evect=0.d0 if(n.gt.0)then c cycle over all eigen vectors for previous N do i=1,(2*(n-1)+1)*9 c calculating of overlap integral do iki=1,nrotor evect(i)=evect(i)+egvc(iki,iji)*oldegv(iki,i) enddo evect(i)=dabs(evect(i)) enddo endif c output two largest overlap integrals c cycle over 2 maximum values of components do iki=1,2 irespos = MAXLOC(evect) c write(11,1916)irespos(1),evect(irespos(1)) evect(irespos(1))=0.d0 enddo c overlap integrals with J-2 evect=0.d0 if(n.gt.1)then c cycle over all eigen vectors for N-2 do i=1,(2*(n-2)+1)*9 c calculating of overlap integral do iki=1,nrotor evect(i)=evect(i)+egvc(iki,iji)*oldegv1(iki,i) enddo evect(i)=dabs(evect(i)) enddo endif c output largest overlap integrals c cycle over 2 maximum values of components do iki=1,2 irespos = MAXLOC(evect) c write(11,1916)irespos(1),evect(irespos(1)) evect(irespos(1))=0.d0 enddo c overlap integrals with J-3 evect=0.d0 if(n.gt.2)then c cycle over all eigen vectors for N-2 do i=1,(2*(n-3)+1)*9 c calculating of overlap integral do iki=1,nrotor evect(i)=evect(i)+egvc(iki,iji)*oldegv2(iki,i) enddo evect(i)=dabs(evect(i)) enddo endif c output largest overlap integrals c cycle over 2 maximum values of components do iki=1,2 irespos = MAXLOC(evect) c write(11,1916)irespos(1),evect(irespos(1)) evect(irespos(1))=0.d0 enddo c overlap integrals with J-4 evect=0.d0 if(n.gt.3)then c cycle over all eigen vectors for N-2 do i=1,(2*(n-4)+1)*9 c calculating of overlap integral do iki=1,nrotor evect(i)=evect(i)+egvc(iki,iji)*oldegv3(iki,i) enddo evect(i)=dabs(evect(i)) enddo endif c output largest overlap integrals c cycle over 2 maximum values of components do iki=1,2 irespos = MAXLOC(evect) c write(11,1916)irespos(1),evect(irespos(1)) evect(irespos(1))=0.d0 enddo c cycle over torsional states sum123=0.d0 do iji1=0,8 c cycle over K values inside the corresponding torsional state do iji2=(2*n+1)*iji1+1,(2*n+1)*(iji1+1) sum123(iji1)=sum123(iji1)+egvc(iji2,iji)**2 enddo enddo do iki=1,2 irespos = MAXLOC(sum123) c write(11,1916)irespos(1)-1,sum123(irespos(1)-1) sum123(irespos(1)-1)=0.d0 enddo c write(11,1917) enddo if(n.gt.2)then c clean the store for n-4 eigen vectors and put there new ones oldegv3=0.d0 do j=1,nrotor iki=0 do i=0,8 iki=iki+1 do iji=1,2*n+1 iki=iki+1 oldegv3(iki,j)=oldegv2(iji+(2*n+1)*i,j) enddo iki=iki+1 enddo enddo endif if(n.gt.1)then c clean the store for n-3 eigen vectors and put there new ones oldegv2=0.d0 do j=1,nrotor iki=0 do i=0,8 iki=iki+1 do iji=1,2*n+1 iki=iki+1 oldegv2(iki,j)=oldegv1(iji+(2*n+1)*i,j) enddo iki=iki+1 enddo enddo endif if(n.gt.0)then c clean the store for n-2 eigen vectors and put there new ones oldegv1=0.d0 do j=1,nrotor iki=0 do i=0,8 iki=iki+1 do iji=1,2*n+1 iki=iki+1 oldegv1(iki,j)=oldegv(iji+(2*n+1)*i,j) enddo iki=iki+1 enddo enddo endif c clean the store for n-1 eigen vectors and put there new ones oldegv=0.d0 do j=1,nrotor iki=0 do i=0,8 iki=iki+1 do iji=1,2*n+1 iki=iki+1 oldegv(iki,j)=egvc(iji+(2*n+1)*i,j) enddo iki=iki+1 enddo enddo endif 1914 format(1x,F15.8,I6,I3,F15.8,I4,E9.1,$) c output of E type energy levels if(isig.eq.1)then c cycle over eigenvalues for a given J value do iji=1,nrotor evect=0.d0 c reduced energy redener=egvl(iji)-cst(lo,2)*n*(n+1) c write(10,1915)redener,n*(n+1),n,egvl(iji),iji c write(6,*)redener,n*(n+1),n,egvl(iji),iji do iki=1,nrotor c if(iki.le.2*n+1)then c write(6,*)egvc(iki,iji) c endif evect(iki)=egvc(iki,iji)**2 enddo c cycle over 2 maximum values of components do iki=1,2 irespos = MAXLOC(evect) c write(10,1916)irespos(1),evect(irespos(1)) evect(irespos(1))=0.d0 enddo c mixing with the same J value evect=0.d0 c cycle over all eigen vectors for previous N do i=1,nrotor if(i.eq.iji)cycle c calculating of overlap integral do iki=1,nrotor evect(i)=evect(i)+dabs(egvc(iki,iji)*egvc(iki,i)) enddo enddo irespos = MAXLOC(evect) c write(10,1916)irespos(1),evect(irespos(1)) c overlap integrals with J-1 evect=0.d0 if(n.gt.0)then c cycle over all eigen vectors for previous N do i=1,(2*(n-1)+1)*9 c calculating of overlap integral do iki=1,nrotor evect(i)=evect(i)+egvc(iki,iji)*oldegv(iki,i) enddo evect(i)=dabs(evect(i)) enddo endif c output largest overlap integrals c cycle over 2 maximum values of components do iki=1,2 irespos = MAXLOC(evect) c write(10,1916)irespos(1),evect(irespos(1)) evect(irespos(1))=0.d0 enddo c overlap integrals with J-2 evect=0.d0 if(n.gt.1)then c cycle over all eigen vectors for previous N do i=1,(2*(n-2)+1)*9 c calculating of overlap integral do iki=1,nrotor evect(i)=evect(i)+egvc(iki,iji)*oldegv1(iki,i) enddo evect(i)=dabs(evect(i)) enddo endif c output largest overlap integrals c cycle over 2 maximum values of components do iki=1,2 irespos = MAXLOC(evect) c write(10,1916)irespos(1),evect(irespos(1)) evect(irespos(1))=0.d0 enddo c overlap integrals with J-3 evect=0.d0 if(n.gt.2)then c cycle over all eigen vectors for previous N do i=1,(2*(n-3)+1)*9 c calculating of overlap integral do iki=1,nrotor evect(i)=evect(i)+egvc(iki,iji)*oldegv2(iki,i) enddo evect(i)=dabs(evect(i)) enddo endif c output largest overlap integrals c cycle over 2 maximum values of components do iki=1,2 irespos = MAXLOC(evect) c write(10,1916)irespos(1),evect(irespos(1)) evect(irespos(1))=0.d0 enddo c overlap integrals with J-4 evect=0.d0 if(n.gt.3)then c cycle over all eigen vectors for previous N do i=1,(2*(n-4)+1)*9 c calculating of overlap integral do iki=1,nrotor evect(i)=evect(i)+egvc(iki,iji)*oldegv3(iki,i) enddo evect(i)=dabs(evect(i)) enddo endif c output largest overlap integrals c cycle over 2 maximum values of components do iki=1,2 irespos = MAXLOC(evect) c write(10,1916)irespos(1),evect(irespos(1)) evect(irespos(1))=0.d0 enddo c cycle over torsional states sum123=0.d0 do iji1=0,8 c cycle over K values inside the corresponding torsional state do iji2=(2*n+1)*iji1+1,(2*n+1)*(iji1+1) sum123(iji1)=sum123(iji1)+egvc(iji2,iji)**2 enddo enddo do iki=1,2 irespos = MAXLOC(sum123) c write(10,1916)irespos(1)-1,sum123(irespos(1)-1) sum123(irespos(1)-1)=0.d0 enddo write(10,1917) enddo 1915 format(1x,F15.8,I6,I3,F15.8,I4,$) 1916 format(I4,F5.2,$) 1917 format(' ') 1919 format(I4,E9.1,$) if(n.gt.2)then c clean the store for n-2 eigen vectors and put there new ones oldegv3=0.d0 do j=1,nrotor iki=0 do i=0,8 iki=iki+1 do iji=1,2*n+1 iki=iki+1 oldegv3(iki,j)=oldegv2(iji+(2*n+1)*i,j) enddo iki=iki+1 enddo enddo endif if(n.gt.1)then c clean the store for n-3 eigen vectors and put there new ones oldegv2=0.d0 do j=1,nrotor iki=0 do i=0,8 iki=iki+1 do iji=1,2*n+1 iki=iki+1 oldegv2(iki,j)=oldegv1(iji+(2*n+1)*i,j) enddo iki=iki+1 enddo enddo endif if(n.gt.0)then c clean the store for n-2 eigen vectors and put there new ones oldegv1=0.d0 do j=1,nrotor iki=0 do i=0,8 iki=iki+1 do iji=1,2*n+1 iki=iki+1 oldegv1(iki,j)=oldegv(iji+(2*n+1)*i,j) enddo iki=iki+1 enddo enddo endif c clean the store for old eigen vectors and put there new ones oldegv=0.d0 do j=1,nrotor iki=0 do i=0,8 iki=iki+1 do iji=1,2*n+1 iki=iki+1 oldegv(iki,j)=egvc(iji+(2*n+1)*i,j) enddo iki=iki+1 enddo enddo endif endif c looking at the eugen vectors c do i=1,nrotor c do k=1,nrotor c evect(k)=egvc(k,i) c enddo c continue c enddo IF (IERR.NE.0) THEN WRITE(6,72) 72 FORMAT(/,' DIAGONALISATION FAILED FOR ROTATION- 1 TORSION ',/) STOP ENDIF c IF (IBUG3.NE.0) THEN C IF (IBUG3.NE.0.AND.N.EQ.13.OR.IBUG2.NE.0.AND.N.EQ.14)THEN IF (IBUG3.NE.0.AND.ISIG.EQ.1) THEN WRITE(6,71) WRITE(6,70) ISIG,N cjth Here I added my own limits for an acetamide printout. CALL MATOU2 (EGVC,EGVL,NDMX,NDMX,2*N+1,2*N+1) c CALL MATOU2 (EGVC,EGVL,NDMX,NDMX,NROTOR,NROTOR) ENDIF 71 FORMAT(//,' ROTATION-TORSION EIGENVALUES AND 1 EIGENVECTORS ',//) IF(IBUG4.NE.0) THEN IF(ISIG.EQ.1) THEN CALL RESUM2(LO,EGVL,EGVC) ELSE CALL RESUM3(LO,EGVL,EGVC) ENDIF ENDIF REWIND 31 REWIND 32 REWIND 33 REWIND 34 END c********************************************************************* SUBROUTINE SETUP(CST) IMPLICIT REAL*8 ( A-H,O-Z ) C THIS SUBROUTINE SETS UP THE DERIV MATRIX WITH ALL THE C ENERGIES AND DERIVATIVES. CHARACTER ABC*702 CHARACTER*6 PARA,REF CHARACTER*1 PR,PROBS PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1) COMMON/EIGEN/H(NDMX,NDMX),WORK(NDMX),EGVC3(KDMX,9),NBR(2) COMMON/EIGEN1/EGVL(2*NDMX),EGVC(NDMX,2*NDMX) COMMON/TOR/A(9,NTORMX,2*KDMX),ETOR(2*KDMX,9) COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRON1 , * IBGTME,IBGVTD ,EVIB(2),IRMW,TERM COMMON/ROTOR/NROTOR,NDIMTO COMMON/PAR/IND(2,80),NP(2),X(160),ITO COMMON/BIG2/DERIV1(10,961,80),ENER(10,961) COMMON/EXPDAT / ETRANS(80000),IVOBS(2,80000), * NOBS(2,80000),KOBS(2,80000),IBLK(2,80000),IW(80000),W(80000), * NDATA,NADAT,EPSI,NOFIT,NFITMW,NFITIR,NFIMW0 ,NFIMW1 ,NITT, * IAST(80000),NFI004 ,NFI080 ,NFI100 ,NFI020 ,NFI200 ,NFI045 , & NGST0 ,NFI010 ,SW070,NFI070 ,NFIMW2,IKAKC,JMAX,NFI1M0, & NFIR10,NFIR21,NFIR32,NFIMW3,NFIMW4,SWA,SWE,NFITMWA,NFITMWE COMMON/SYMB/ABC COMMON/QUANT/ISIG,IV,N,KK COMMON/CHARA/PARA(2,160),PR,PROBS(2,80000),REF(80000) DIMENSION UNIT(160,160),V(160),V1(160),V2(160),CST(2,117) C C INITIALIZATION JJMAX=(JMAX+1)**2 DO 99 I=1,10 DO 100 J=1,JJMAX DO 101 JJ=1,NP(1) ENER(I,J)=0.0 DERIV1(I,J,JJ)=0.0 101 CONTINUE 100 CONTINUE 99 CONTINUE LO=1 NI=1 M=1 LOO=LO c !$OMP PARALLEL DO DO 5 ISIG=0,1 IF(ISIG.EQ.1) THEN c !$OMP PARALLEL DO DO 20 N=0,JMAX CALL ROTTOR(CST,LO,EGVL(NI),EGVC(1,NI),ETOR(M,1), 1 A(1,1,M),nitt) NROTOR=(2*N+1)*9 DO 10 IV=0,2 DO 30 KK=-N,N CALL ENCAL(E,LOO,EGVL(NI),EGVC(1,NI),A(1,1,M)) CALL VSET(1,V1,CST) C PRINT*,'E=',E,'IV=',IV,'KK=',KK,'N=',N C 1,'NROTOR=',NROTOR,'LOO=',LOO,'ISIG=',ISIG INK=N**2+N+KK+1 ENER(IV+6,INK)=E C PRINT*,'INK=',INK,'ENER=',ENER DO 40 I=1,NP(1) DERIV1(IV+6,INK,I)=V1(I) IF(N.EQ.5) THEN c PRINT*,'V1=',V1(I),'N=',N,'IV=',IV, c 1 'KK=',KK,'ISIG=',ISIG,'PARAMETER FITTED=',I,'ENER=', c 2 ENER(IV+6,INK) ENDIF 40 CONTINUE 30 CONTINUE 10 CONTINUE 20 CONTINUE c !$OMP END PARALLEL ELSE c !$OMP PARALLEL DO DO 21 N=0,JMAX CALL ROTTOR(CST,LO,EGVL(NI),EGVC(1,NI),ETOR(M,1) 1 ,A(1,1,M),nitt) NROTOR=(2*N+1)*9 DO 11 IV=0,2 DO 31 KK=0,N IF(KK.EQ.0) THEN PR='+' IPR=1 CALL ENCAL(E,LOO,EGVL(NI),EGVC(1,NI),A(1,1,M)) CALL VSET(1,V1,CST) INK=N**2+N+KK+1-IPR*N ENER(IV+1,INK)=E DO 41 I=1,NP(1) DERIV1(IV+1,INK,I)=V1(I) IF(N.EQ.5) THEN c PRINT*,'V1=',V1(I),'N=',N,'IV=',IV,'IPR=',IPR, c 1 'KK=',KK,'ISIG=',ISIG,'PARAMETER FITTED=',I,'ENER=', c 2 ENER(IV+1,INK) ENDIF 41 CONTINUE ELSE DO 32 IPR=0,1 IF(IPR.EQ.0) PR='-' IF(IPR.EQ.1) PR='+' INK=N**2+N+KK+1-IPR*N CALL ENCAL(E,LOO,EGVL(NI),EGVC(1,NI), 1 A(1,1,M)) CALL VSET(1,V1,CST) ENER(IV+1,INK)=E C PRINT*,'ENER=',ENER,'INK=',INK DO 42 I=1,NP(1) DERIV1(IV+1,INK,I)=V1(I) IF(N.EQ.5) THEN c PRINT*,'V1=',V1(I),'N=',N,'IV=',IV,'IPR=',IPR c 1 ,'KK=',KK,'ISIG=',ISIG,'PARAMETER FITTED=',I,'ENER=', c 2 ENER(IV+1,INK) ENDIF 42 CONTINUE 32 CONTINUE ENDIF 31 CONTINUE 11 CONTINUE 21 CONTINUE c !$OMP END PARALLEL ENDIF 5 CONTINUE c !$OMP END PARALLEL RETURN END C***************************************************************** C HERE BEGINS A TEST FOR THE CASE OF A IMPORTANT MIXING OF THE C E STATES BETWEEN +K AND -K BASIS FUNCTIONS C I2=I-2*KK C RATIO=EGVC(I,IPOSE)/EGVC(I2,IPOSE) C ISGN=' ' C IF(ABS(RATIO).GT.EPS) THEN C ISGN='+' C IF(RATIO.LT.0.0) ISGN='-' C ENDIF C RETURN C END C*********************************************************** FUNCTION VRTDI1 (L, LO) c my insertion IMPLICIT REAL*8 ( A-H,O-Z ) C*********************************************************** C DERIVATIVES OF THE ENERGY INVOLVING THE DIAGONAL ELEMENTS OF C HAMILTONIAN(PARAMETERS:DA,B,C,DJ,DJK,DK,HJ,HJK,HKJ,HK) C CHARACTER*1 PR,PROBS CHARACTER * 6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1) COMMON / EIGEN / H(NDMX,NDMX),WORK(NDMX),EGVC3(KDMX,9),NBR(2) COMMON / CHARA / PARA (2,160), PR, PROBS (2,80000), REF (80000) COMMON / QUANT / ISIG, IV, N, KK * REAL*8 A1T1(KDMX,9,9), & A1T2(KDMX,9,9),A2T2(KDMX,9,9),A3T2(KDMX,9,9), & A4T2(KDMX,9,9),A5T2(KDMX,9,9),A7T2(KDMX,9,9), & A1T4(KDMX,9,9),A2T4(KDMX,9,9),A3T4(KDMX,9,9), & A4T4(KDMX,9,9),A5T4(KDMX,9,9),A6T4(KDMX,9,9), & A1T5(KDMX,9,9),A2T5(KDMX,9,9),A3T5(KDMX,9,9), & A4T5(KDMX,9,9),A5T5(KDMX,9,9), & A4T5B(KDMX,9,9),A5T5B(KDMX,9,9), & A4T5BB(KDMX,9,9),A5T5BB(KDMX,9,9), & A7T5(KDMX,9,9),A8T5(KDMX,9,9),A9T5(KDMX,9,9), & A10T5(KDMX,9,9),A11T5(KDMX,9,9),A12T5(KDMX,9,9), & A13T5(KDMX,9,9),A14T5(KDMX,9,9),A15T5(KDMX,9,9), & A16T5(KDMX,9,9),A17T5(KDMX,9,9), & A1TS(KDMX,9,9),A2TS(KDMX,9,9),A5TS(KDMX,9,9), & A8T2(KDMX,9,9),A9T2(KDMX,9,9), & A20T4(KDMX,9,9),A21T4(KDMX,9,9) & ,A8T5B(KDMX,9,9),A9T5B(KDMX,9,9), & A14T5B(KDMX,9,9),A15T5B(KDMX,9,9) & ,A5T4B(KDMX,9,9),A6T4B(KDMX,9,9) & ,A10T2(KDMX,9,9),A11T2(KDMX,9,9),A1T4B(KDMX,9,9) & ,A10T5B(KDMX,9,9),A11T5B(KDMX,9,9) & ,A16T5B(KDMX,9,9),A17T5B(KDMX,9,9) & ,A6TS(KDMX,9,9),A18T5(KDMX,9,9),A19T5(KDMX,9,9) & ,A3T4B(KDMX,9,9),A4T4B(KDMX,9,9),A4T2B(KDMX,9,9) & ,A5T2B(KDMX,9,9) & ,A20T5(KDMX,9,9),A21T5(KDMX,9,9) COMMON /VRTD/ A1T1,A1T2,A2T2,A3T2,A4T2,A5T2,A7T2, & A1T4,A2T4,A3T4,A4T4,A5T4,A6T4, & A1T5,A2T5,A3T5,A4T5,A5T5,A7T5,A8T5,A9T5, & A10T5,A11T5,A12T5,A13T5,A14T5,A15T5,A16T5,A17T5, & A1TS,A2TS,A5TS,A8T2,A9T2,A20T4,A21T4 & ,A8T5B,A9T5B,A14T5B,A15T5B & ,A4T5B,A5T5B,A5T4B,A6T4B,A4T5BB,A5T5BB & ,A10T2,A11T2,A1T4B,A10T5B,A11T5B,A16T5B,A17T5B & ,A6TS,A18T5,A19T5,A3T4B,A4T4B,A4T2B,A5T2B & ,A20T5,A21T5 * REAL*8 EGTA(KDMX,9,9) * DO 1004 IVTORP = 1,9 DO 1002 IVTOR1 = 1,9 DO 1000 I = 1, 2 * N + 1 EGTA(I,IVTOR1,IVTORP) = EGVC3(I,IVTORP) * EGVC3(I,IVTOR1) & * A1T1(I,IVTOR1,IVTORP) 1000 CONTINUE 1002 CONTINUE 1004 CONTINUE * IF (PARA(LO, L).EQ.'B ' .OR. PARA(LO, L).EQ.'C ' .OR. & PARA(LO, L).EQ.'DJ ' .OR. PARA(LO, L).EQ.'HJ ') THEN VRTDIA = 0.0 DO 7004 IVTORP = 1,9 DO 7002 IVTOR1 = 1,9 DO 7000 I = 1, 2 * N + 1 VRTDIA = VRTDIA + EGTA(I,IVTOR1,IVTORP) 7000 CONTINUE 7002 CONTINUE 7004 CONTINUE END IF * IF (PARA(LO, L).EQ.'OA ' .OR. PARA(LO, L).EQ.'B ' .OR. & PARA(LO, L).EQ.'C ' .OR. PARA(LO, L).EQ.'DJK ' .OR. & PARA(LO, L).EQ.'HJK ') THEN VRTDIB = 0.0 DO 7014 IVTORP = 1,9 DO 7012 IVTOR1 = 1,9 DO 7010 I = 1, 2 * N + 1 K = I - N - 1 VRTDIB = VRTDIB + EGTA(I,IVTOR1,IVTORP) * K * K 7010 CONTINUE 7012 CONTINUE 7014 CONTINUE END IF * IF (PARA(LO, L).EQ.'DK ' .OR. PARA(LO, L).EQ.'HKJ ') THEN VRTDIC = 0.0 DO 7024 IVTORP = 1,9 DO 7022 IVTOR1 = 1,9 DO 7020 I = 1, 2 * N + 1 K = I - N - 1 VRTDIC = VRTDIC + EGTA(I,IVTOR1,IVTORP) * K * K * K *K 7020 CONTINUE 7022 CONTINUE 7024 CONTINUE END IF * IF (PARA(LO, L).EQ.'HK ' .OR. PARA(LO, L).EQ.'HLKJ ') THEN VRTDID = 0.0 DO 7034 IVTORP = 1,9 DO 7032 IVTOR1 = 1,9 DO 7030 I = 1, 2 * N + 1 K = I - N - 1 VRTDID = VRTDID + EGTA(I,IVTOR1,IVTORP) * K*K*K*K*K*K 7030 CONTINUE 7032 CONTINUE 7034 CONTINUE END IF * IF (PARA(LO, L).EQ. 'OA ') THEN VRTDI1 = VRTDIB ELSE IF (PARA(LO, L).EQ.'B '.OR.PARA(LO, L).EQ.'C ') THEN VRTDI1 = 0.5 * (VRTDIA * N*(N+1) - VRTDIB) ELSE IF (PARA(LO, L).EQ.'DJ ') THEN VRTDI1 = - VRTDIA * N*(N+1)*N*(N+1) ELSE IF (PARA(LO, L).EQ.'DJK ') THEN VRTDI1 = - VRTDIB * N*(N+1) ELSE IF (PARA(LO, L).EQ.'DK ') THEN VRTDI1 = - VRTDIC ELSE IF (PARA(LO, L).EQ.'HJ ') THEN VRTDI1 = VRTDIA * (N*(N+1)) ** 3 ELSE IF (PARA (LO, L) .EQ. 'HJK ') THEN VRTDI1 = VRTDIB * N*(N+1)*N*(N+1) ELSE IF (PARA (LO, L) .EQ. 'HKJ ') THEN VRTDI1 = VRTDIC * N*(N+1) ELSE IF (PARA (LO, L) .EQ. 'HK ') THEN VRTDI1 = VRTDID ELSE IF (PARA (LO, L) .EQ. 'HLKJ ') THEN VRTDI1 = VRTDID * N*(N+1) END IF END C********************************************************** FUNCTION VRTDI2 (L, LO) c my insertion IMPLICIT REAL*8 ( A-H,O-Z ) C IMPLICIT DOUBLE PRECISION (A - H, O - Z) C************************************************************ C DERIVATIVES INVOLVING THE K/K+ OU - 2 MATRIX ELEMENTS OF C THE HAMILTONIAN(B,C,ODELN,ODELK,OHJ,OHJK,OHK,C1,C2,C3) C CHARACTER*1 PR,PROBS CHARACTER * 6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1) COMMON / EIGEN / H(NDMX,NDMX),WORK(NDMX),EGVC3(KDMX,9),NBR(2) COMMON / QUANT / ISIG, IV, N, KK COMMON / CHARA / PARA (2,160), PR, PROBS (2,80000), REF (80000) * REAL*8 A1T1(KDMX,9,9), & A1T2(KDMX,9,9),A2T2(KDMX,9,9),A3T2(KDMX,9,9), & A4T2(KDMX,9,9),A5T2(KDMX,9,9),A7T2(KDMX,9,9), & A1T4(KDMX,9,9),A2T4(KDMX,9,9),A3T4(KDMX,9,9), & A4T4(KDMX,9,9),A5T4(KDMX,9,9),A6T4(KDMX,9,9), & A1T5(KDMX,9,9),A2T5(KDMX,9,9),A3T5(KDMX,9,9), & A4T5(KDMX,9,9),A5T5(KDMX,9,9), & A4T5B(KDMX,9,9),A5T5B(KDMX,9,9), & A4T5BB(KDMX,9,9),A5T5BB(KDMX,9,9), & A7T5(KDMX,9,9),A8T5(KDMX,9,9),A9T5(KDMX,9,9), & A10T5(KDMX,9,9),A11T5(KDMX,9,9),A12T5(KDMX,9,9), & A13T5(KDMX,9,9),A14T5(KDMX,9,9),A15T5(KDMX,9,9), & A16T5(KDMX,9,9),A17T5(KDMX,9,9), & A1TS(KDMX,9,9),A2TS(KDMX,9,9),A5TS(KDMX,9,9), & A8T2(KDMX,9,9),A9T2(KDMX,9,9), & A20T4(KDMX,9,9),A21T4(KDMX,9,9) & ,A8T5B(KDMX,9,9),A9T5B(KDMX,9,9), & A14T5B(KDMX,9,9),A15T5B(KDMX,9,9) & ,A5T4B(KDMX,9,9),A6T4B(KDMX,9,9) & ,A10T2(KDMX,9,9),A11T2(KDMX,9,9),A1T4B(KDMX,9,9) & ,A10T5B(KDMX,9,9),A11T5B(KDMX,9,9) & ,A16T5B(KDMX,9,9),A17T5B(KDMX,9,9) & ,A6TS(KDMX,9,9),A18T5(KDMX,9,9),A19T5(KDMX,9,9) & ,A3T4B(KDMX,9,9),A4T4B(KDMX,9,9),A4T2B(KDMX,9,9) & ,A5T2B(KDMX,9,9) & ,A20T5(KDMX,9,9),A21T5(KDMX,9,9) COMMON /VRTD/ A1T1,A1T2,A2T2,A3T2,A4T2,A5T2,A7T2, & A1T4,A2T4,A3T4,A4T4,A5T4,A6T4, & A1T5,A2T5,A3T5,A4T5,A5T5,A7T5,A8T5,A9T5, & A10T5,A11T5,A12T5,A13T5,A14T5,A15T5,A16T5,A17T5, & A1TS,A2TS,A5TS,A8T2,A9T2,A20T4,A21T4 & ,A8T5B,A9T5B,A14T5B,A15T5B & ,A4T5B,A5T5B,A5T4B,A6T4B,A4T5BB,A5T5BB & ,A10T2,A11T2,A1T4B,A10T5B,A11T5B,A16T5B,A17T5B & ,A6TS,A18T5,A19T5,A3T4B,A4T4B,A4T2B,A5T2B & ,A20T5,A21T5 * REAL*8 EGT(KDMX,9,9),SQT(KDMX) * DO 500 I = 1, 2 * N - 1 SQT(I) = 2. * SQRT (FLOAT ((N*(N+1) - (I-N-1)*(I-N)) & * (N*(N+1) - (I-N)*(I-N+1)))) 500 CONTINUE DO 1004 IVTORP = 1,9 DO 1002 IVTOR1 = 1,9 DO 1000 I = 1, 2 * N - 1 EGT(I,IVTOR1,IVTORP) = SQT(I) * EGVC3(I,IVTORP) & * EGVC3(I+2,IVTOR1) 1000 CONTINUE 1002 CONTINUE 1004 CONTINUE * IF (PARA(LO,L).EQ.'B ' .OR. PARA(LO,L).EQ.'C ' .OR. & PARA(LO,L).EQ.'ODELN ' .OR. PARA(LO,L).EQ.'OHJ ') THEN VRTDIA = 0.0 DO 7004 IVTORP = 1,9 DO 7002 IVTOR1 = 1,9 DO 7000 I = 1, 2 * N - 1 VRTDIA = VRTDIA + EGT(I,IVTOR1,IVTORP) & * A1T2(I,IVTOR1,IVTORP) 7000 CONTINUE 7002 CONTINUE 7004 CONTINUE END IF * IF (PARA(LO,L).EQ.'ODELK '.OR. PARA(LO,L).EQ.'OHJK ') THEN VRTDIB = 0.0 DO 7014 IVTORP = 1,9 DO 7012 IVTOR1 = 1,9 DO 7010 I = 1, 2 * N - 1 K = I - N - 1 VRTDIB = VRTDIB + EGT(I,IVTOR1,IVTORP) & * (K*K + (K+2)*(K+2)) * A1T2(I,IVTOR1,IVTORP) 7010 CONTINUE 7012 CONTINUE 7014 CONTINUE END IF * IF (PARA(LO,L).EQ.'OHK ') THEN VRTDIC = 0.0 DO 7024 IVTORP = 1,9 DO 7022 IVTOR1 = 1,9 DO 7020 I = 1, 2 * N - 1 K = I - N - 1 VRTDIC = VRTDIC + EGT(I,IVTOR1,IVTORP) & * (K**4 + (K+2)**4) * A1T2(I,IVTOR1,IVTORP) 7020 CONTINUE 7022 CONTINUE 7024 CONTINUE END IF * IF (PARA(LO,L).EQ.'C1 ' .OR. PARA(LO,L).EQ.'C1J ') THEN VRTDID = 0.0 DO 7034 IVTORP = 1,9 DO 7032 IVTOR1 = 1,9 DO 7030 I = 1, 2 * N - 1 VRTDID = VRTDID + EGT(I,IVTOR1,IVTORP) & * A2T2(I,IVTOR1,IVTORP) 7030 CONTINUE 7032 CONTINUE 7034 CONTINUE END IF * IF (PARA(LO,L).EQ.'C1K ') THEN VRTDII = 0.0 DO 7084 IVTORP = 1,9 DO 7082 IVTOR1 = 1,9 DO 7080 I = 1, 2 * N - 1 K=I-N-1 VRTDII = VRTDII + EGT(I,IVTOR1,IVTORP) & * A2T2(I,IVTOR1,IVTORP) & *(K**2+(K+2)**2) 7080 CONTINUE 7082 CONTINUE 7084 CONTINUE END IF IF (PARA(LO,L).EQ.'C2 ' .OR. PARA(LO,L).EQ.'C2J ') THEN VRTDIE = 0.0 DO 7044 IVTORP = 1,9 DO 7042 IVTOR1 = 1,9 DO 7040 I = 1, 2 * N - 1 VRTDIE = VRTDIE + EGT(I,IVTOR1,IVTORP) & * (A1T2(I,IVTOR1,IVTORP) & - 0.5 * (A4T2(I,IVTOR1,IVTORP) & + A5T2(I,IVTOR1,IVTORP))) 7040 CONTINUE 7042 CONTINUE 7044 CONTINUE END IF * IF (PARA(LO,L).EQ.'C2K ')THEN VRTDIJ = 0.0 DO 7094 IVTORP = 1,9 DO 7092 IVTOR1 = 1,9 DO 7090 I = 1, 2 * N - 1 K=I-N-1 VRTDIJ = VRTDIJ + EGT(I,IVTOR1,IVTORP) & * (A1T2(I,IVTOR1,IVTORP) & - 0.5 * (A4T2(I,IVTOR1,IVTORP) & + A5T2(I,IVTOR1,IVTORP))) & *(K**2+(K+2)**2) 7090 CONTINUE 7092 CONTINUE 7094 CONTINUE END IF IF (PARA(LO,L).EQ.'C11 ' .OR. PARA(LO,L).EQ.'C11J ') THEN VRTDIK = 0.0 DO 7244 IVTORP = 1,9 DO 7242 IVTOR1 = 1,9 DO 7240 I = 1, 2 * N - 1 VRTDIK = VRTDIK + EGT(I,IVTOR1,IVTORP) & * (A1T2(I,IVTOR1,IVTORP) & - 0.5 * (A8T2(I,IVTOR1,IVTORP) & + A9T2(I,IVTOR1,IVTORP))) 7240 CONTINUE 7242 CONTINUE 7244 CONTINUE END IF * IF (PARA(LO,L).EQ.'C11K ') THEN VRTDIK2= 0.0 DO 7299 IVTORP = 1,9 DO 7298 IVTOR1 = 1,9 DO 7297 I = 1, 2 * N - 1 K=I-N-1 VRTDIK2= VRTDIK2+ EGT(I,IVTOR1,IVTORP) & * (A1T2(I,IVTOR1,IVTORP) & - 0.5 * (A8T2(I,IVTOR1,IVTORP) & + A9T2(I,IVTOR1,IVTORP))) & *(K**2+(K+2)**2) 7297 CONTINUE 7298 CONTINUE 7299 CONTINUE END IF * IF (PARA(LO,L).EQ.'C3 '.OR.PARA(LO,L).EQ.'C3J ') THEN VRTDIF = 0.0 DO 7054 IVTORP = 1,9 DO 7052 IVTOR1 = 1,9 DO 7050 I = 1, 2 * N - 1 VRTDIF = VRTDIF + EGT(I,IVTOR1,IVTORP) & * A3T2(I,IVTOR1,IVTORP) 7050 CONTINUE 7052 CONTINUE 7054 CONTINUE END IF * IF (PARA(LO,L).EQ.'DBC ') THEN VRTDIG = 0.0 DO 7064 IVTORP = 1,9 DO 7062 IVTOR1 = 1,9 DO 7060 I = 1, 2 * N - 1 VRTDIG = VRTDIG + EGT(I,IVTOR1,IVTORP) & * (A4T2(I,IVTOR1,IVTORP) - A5T2(I,IVTOR1,IVTORP)) 7060 CONTINUE 7062 CONTINUE 7064 CONTINUE END IF * IF (PARA(LO,L).EQ.'DBCJ ') THEN VRTDIG3= 0.0 DO 8064 IVTORP = 1,9 DO 8062 IVTOR1 = 1,9 DO 8060 I = 1, 2 * N - 1 VRTDIG3= VRTDIG3+ EGT(I,IVTOR1,IVTORP) & * (A4T2(I,IVTOR1,IVTORP) - A5T2(I,IVTOR1,IVTORP)) & * (N*(N+1)) 8060 CONTINUE 8062 CONTINUE 8064 CONTINUE END IF IF (PARA(LO,L).EQ.'DBC12 ') THEN VRTDIG2= 0.0 DO 2064 IVTORP = 1,9 DO 2062 IVTOR1 = 1,9 DO 2060 I = 1, 2 * N - 1 VRTDIG2= VRTDIG2+ EGT(I,IVTOR1,IVTORP) & * (A4T2B(I,IVTOR1,IVTORP) - A5T2B(I,IVTOR1,IVTORP)) 2060 CONTINUE 2062 CONTINUE 2064 CONTINUE END IF * IF (PARA(LO,L).EQ.'C4 '.OR.PARA(LO,L).EQ.'C4J ')THEN VRTDIH = 0.0 DO 7074 IVTORP = 1,9 DO 7072 IVTOR1 = 1,9 DO 7070 I = 1, 2 * N - 1 VRTDIH = VRTDIH + EGT(I,IVTOR1,IVTORP) & * A7T2(I,IVTOR1,IVTORP) 7070 CONTINUE 7072 CONTINUE 7074 CONTINUE END IF * IF (PARA(LO,L).EQ.'C12 '.OR.PARA(LO,L).EQ.'C12J ')THEN VRTDIL = 0.0 DO 7104 IVTORP = 1,9 DO 7102 IVTOR1 = 1,9 DO 7100 I = 1, 2 * N - 1 VRTDIL = VRTDIL + EGT(I,IVTOR1,IVTORP) & * A10T2(I,IVTOR1,IVTORP) 7100 CONTINUE 7102 CONTINUE 7104 CONTINUE END IF * IF (PARA(LO,L).EQ.'C4K ') THEN VRTDIM = 0.0 DO 7124 IVTORP = 1,9 DO 7122 IVTOR1 = 1,9 DO 7120 I = 1, 2 * N - 1 VRTDIM = VRTDIM + EGT(I,IVTOR1,IVTORP) & * A11T2(I,IVTOR1,IVTORP) 7120 CONTINUE 7122 CONTINUE 7124 CONTINUE END IF * IF (PARA(LO,L).EQ.'B ') THEN VRTDI2 = 0.25 * VRTDIA ELSE IF (PARA(LO,L).EQ.'C ') THEN VRTDI2 = -0.25 * VRTDIA ELSE IF (PARA(LO,L).EQ.'ODELN ') THEN VRTDI2 = - VRTDIA * N*(N+1) ELSE IF (PARA(LO,L).EQ.'ODELK ') THEN VRTDI2 = -0.5 * VRTDIB ELSE IF (PARA(LO,L).EQ.'OHJ ') THEN VRTDI2 = VRTDIA * N*(N+1)*N*(N+1) ELSE IF (PARA(LO,L).EQ.'OHJK ') THEN VRTDI2 = 0.5 * VRTDIB *N*(N+1) ELSE IF (PARA(LO,L).EQ.'OHK ') THEN VRTDI2 = 0.5 * VRTDIC ELSE IF (PARA(LO,L).EQ.'C1 ') THEN VRTDI2 = 0.5 * VRTDID ELSE IF (PARA(LO,L).EQ.'C1J ') THEN VRTDI2 = 0.5 * VRTDID * N*(N+1) ELSE IF (PARA(LO,L).EQ.'C2 ') THEN VRTDI2 = 0.5 * VRTDIE ELSE IF (PARA(LO,L).EQ.'C2J ') THEN VRTDI2 = 0.5 * VRTDIE * N*(N+1) ELSE IF (PARA(LO,L).EQ.'C11 ') THEN VRTDI2 = 0.5 * VRTDIK ELSE IF (PARA(LO,L).EQ.'C11J ') THEN VRTDI2 = 0.5 * VRTDIK*N*(N+1) ELSE IF (PARA(LO,L).EQ.'C11K ') THEN VRTDI2 = 0.5 * VRTDIK2 ELSE IF (PARA(LO,L).EQ.'C3 ') THEN VRTDI2 = 0.5 * VRTDIF ELSE IF (PARA(LO,L).EQ.'C3J ') THEN VRTDI2 = 0.5 * VRTDIF*N*(N+1) ELSE IF (PARA(LO,L).EQ.'DBC ') THEN VRTDI2 = -0.25 * VRTDIG ELSE IF (PARA(LO,L).EQ.'DBCJ ') THEN VRTDI2 = -0.25 * VRTDIG3 ELSE IF (PARA(LO,L).EQ.'DBC12 ') THEN VRTDI2 = -0.25 * VRTDIG2 ELSE IF (PARA(LO,L).EQ.'C4 ') THEN VRTDI2 = 0.5 * VRTDIH ELSE IF (PARA(LO,L).EQ.'C4J ') THEN VRTDI2 = 0.5 * VRTDIH*N*(N+1) ELSE IF (PARA(LO,L).EQ.'C1K ') THEN VRTDI2=0.5 * VRTDII ELSE IF (PARA(LO,L).EQ.'C2K ') THEN VRTDI2=0.5* VRTDIJ ELSE IF (PARA(LO,L).EQ.'C12 ') THEN VRTDI2=0.5* VRTDIL ELSE IF (PARA(LO,L).EQ.'C12J ') THEN VRTDI2=0.5* VRTDIL*N*(N+1) ELSE IF (PARA(LO,L).EQ.'C4K ') THEN VRTDI2=0.5* VRTDIM END IF END C*********************************************************** FUNCTION VRTDI4 (L, LO) c my insertion IMPLICIT REAL*8 ( A-H,O-Z ) C IMPLICIT DOUBLE PRECISION (A - H, O - Z) C********************************************************** C DERIVATIVES INVOLVING THE K/K+OR-1 MATRIX ELEMENTS OF THE C MATRIX ELEMENT(DAB,ODAB,DABJ,DABK) C CHARACTER*1 PR,PROBS CHARACTER*6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1) COMMON / EIGEN / H(NDMX,NDMX),WORK(NDMX),EGVC3(KDMX,9),NBR(2) COMMON / CHARA / PARA (2,160), PR, PROBS (2,80000), REF (80000) COMMON / QUANT / ISIG, IV, N, KK * REAL*8 A1T1(KDMX,9,9), & A1T2(KDMX,9,9),A2T2(KDMX,9,9),A3T2(KDMX,9,9), & A4T2(KDMX,9,9),A5T2(KDMX,9,9),A7T2(KDMX,9,9), & A1T4(KDMX,9,9),A2T4(KDMX,9,9),A3T4(KDMX,9,9), & A4T4(KDMX,9,9),A5T4(KDMX,9,9),A6T4(KDMX,9,9), & A1T5(KDMX,9,9),A2T5(KDMX,9,9),A3T5(KDMX,9,9), & A4T5(KDMX,9,9),A5T5(KDMX,9,9), & A4T5B(KDMX,9,9),A5T5B(KDMX,9,9), & A4T5BB(KDMX,9,9),A5T5BB(KDMX,9,9), & A7T5(KDMX,9,9),A8T5(KDMX,9,9),A9T5(KDMX,9,9), & A10T5(KDMX,9,9),A11T5(KDMX,9,9),A12T5(KDMX,9,9), & A13T5(KDMX,9,9),A14T5(KDMX,9,9),A15T5(KDMX,9,9), & A16T5(KDMX,9,9),A17T5(KDMX,9,9), & A1TS(KDMX,9,9),A2TS(KDMX,9,9),A5TS(KDMX,9,9), & A8T2(KDMX,9,9),A9T2(KDMX,9,9), & A20T4(KDMX,9,9),A21T4(KDMX,9,9) & ,A8T5B(KDMX,9,9),A9T5B(KDMX,9,9), & A14T5B(KDMX,9,9),A15T5B(KDMX,9,9) & ,A5T4B(KDMX,9,9),A6T4B(KDMX,9,9) & ,A10T2(KDMX,9,9),A11T2(KDMX,9,9),A1T4B(KDMX,9,9) & ,A10T5B(KDMX,9,9),A11T5B(KDMX,9,9) & ,A16T5B(KDMX,9,9),A17T5B(KDMX,9,9) & ,A6TS(KDMX,9,9),A18T5(KDMX,9,9),A19T5(KDMX,9,9) & ,A3T4B(KDMX,9,9),A4T4B(KDMX,9,9),A4T2B(KDMX,9,9) & ,A5T2B(KDMX,9,9) & ,A20T5(KDMX,9,9),A21T5(KDMX,9,9) COMMON /VRTD/ A1T1,A1T2,A2T2,A3T2,A4T2,A5T2,A7T2, & A1T4,A2T4,A3T4,A4T4,A5T4,A6T4, & A1T5,A2T5,A3T5,A4T5,A5T5,A7T5,A8T5,A9T5, & A10T5,A11T5,A12T5,A13T5,A14T5,A15T5,A16T5,A17T5, & A1TS,A2TS,A5TS,A8T2,A9T2,A20T4,A21T4 & ,A8T5B,A9T5B,A14T5B,A15T5B & ,A4T5B,A5T5B,A5T4B,A6T4B,A4T5BB,A5T5BB & ,A10T2,A11T2,A1T4B,A10T5B,A11T5B,A16T5B,A17T5B & ,A6TS,A18T5,A19T5,A3T4B,A4T4B,A4T2B,A5T2B & ,A20T5,A21T5 * REAL*8 EGT(KDMX,9,9),SQT(KDMX) * DO 500 I = 1, 2 * N SQT(I) = SQRT (FLOAT(N*(N+1) - (I-N-1)*(I-N))) 500 CONTINUE DO 1004 IVTORP = 1,9 DO 1002 IVTOR1 = 1,9 DO 1000 I = 1, 2 * N EGT(I,IVTOR1,IVTORP) = SQT(I) * EGVC3(I,IVTORP) & * EGVC3(I+1,IVTOR1) 1000 CONTINUE 1002 CONTINUE 1004 CONTINUE * VRTDI4 = 0.0 * IF (PARA (LO, L) .EQ. 'DAB ') THEN DO 7000 IVTORP = 1,9 DO 7002 IVTOR1 = 1,9 DO 7004 I = 1, 2 * N VRTDI4 = VRTDI4 + 2. * EGT(I,IVTOR1,IVTORP) & * (I - N - 0.5) * A1T4(I,IVTOR1,IVTORP) 7004 CONTINUE 7002 CONTINUE 7000 CONTINUE ELSEIF (PARA (LO, L) .EQ. 'ESPOIR') THEN DO 2000 IVTORP = 1,9 DO 2002 IVTOR1 = 1,9 DO 2004 I = 1, 2 * N VRTDI4 = VRTDI4 + EGT(I,IVTOR1,IVTORP) & * A1T4B(I,IVTOR1,IVTORP) 2004 CONTINUE 2002 CONTINUE 2000 CONTINUE ELSE IF (PARA (LO, L) .EQ. 'ODAB ') THEN DO 7010 IVTORP = 1,9 DO 7012 IVTOR1 = 1,9 DO 7014 I = 1, 2 * N VRTDI4 = VRTDI4 + 2. * EGT(I,IVTOR1,IVTORP) & * (I - N - 0.5) & * (A1T4(I,IVTOR1,IVTORP) & - 0.5 * (A2T4(I,IVTOR1,IVTORP) & + A3T4(I,IVTOR1,IVTORP))) 7014 CONTINUE 7012 CONTINUE 7010 CONTINUE ELSE IF (PARA (LO, L) .EQ. 'ODABJ ') THEN DO 8010 IVTORP = 1,9 DO 8012 IVTOR1 = 1,9 DO 8014 I = 1, 2 * N VRTDI4 = VRTDI4 + 2. * EGT(I,IVTOR1,IVTORP) & * (I - N - 0.5) & *(N*(N+1)) & * (A1T4(I,IVTOR1,IVTORP) & - 0.5 * (A2T4(I,IVTOR1,IVTORP) & + A3T4(I,IVTOR1,IVTORP))) 8014 CONTINUE 8012 CONTINUE 8010 CONTINUE ELSE IF (PARA (LO, L) .EQ. 'ODABJJ') THEN DO 9099 IVTORP = 1,9 DO 9098 IVTOR1 = 1,9 DO 9097 I = 1, 2 * N VRTDI4 = VRTDI4 + 2. * EGT(I,IVTOR1,IVTORP) & * (I - N - 0.5) & *(N*(N+1))*(N*(N+1)) & * (A1T4(I,IVTOR1,IVTORP) & - 0.5 * (A2T4(I,IVTOR1,IVTORP) & + A3T4(I,IVTOR1,IVTORP))) 9097 CONTINUE 9098 CONTINUE 9099 CONTINUE ELSE IF (PARA (LO, L) .EQ. 'ODAB6 ') THEN DO 7210 IVTORP = 1,9 DO 7212 IVTOR1 = 1,9 DO 7214 I = 1, 2 * N VRTDI4 = VRTDI4 + 2. * EGT(I,IVTOR1,IVTORP) & * (I - N - 0.5) & * (A1T4(I,IVTOR1,IVTORP) & - 0.5 * (A20T4(I,IVTOR1,IVTORP) & + A21T4(I,IVTOR1,IVTORP))) 7214 CONTINUE 7212 CONTINUE 7210 CONTINUE ELSE IF (PARA (LO, L) .EQ. 'DABJ ') THEN DO 7020 IVTORP = 1,9 DO 7022 IVTOR1 = 1,9 DO 7024 I = 1, 2 * N VRTDI4 = VRTDI4 + 2. * EGT(I,IVTOR1,IVTORP) & * (I - N - 0.5) & * A1T4(I,IVTOR1,IVTORP) * N * (N+1) 7024 CONTINUE 7022 CONTINUE 7020 CONTINUE ELSE IF (PARA (LO, L) .EQ. 'DABJJ ') THEN DO 7099 IVTORP = 1,9 DO 7098 IVTOR1 = 1,9 DO 7097 I = 1, 2 * N VRTDI4 = VRTDI4 + 2. * EGT(I,IVTOR1,IVTORP) & * (I - N - 0.5) & * A1T4(I,IVTOR1,IVTORP) * N * (N+1) & *N*(N+1) 7097 CONTINUE 7098 CONTINUE 7099 CONTINUE ELSE IF (PARA (LO, L) .EQ. 'DABK ') THEN DO 7030 IVTORP = 1,9 DO 7032 IVTOR1 = 1,9 DO 7034 I = 1, 2 * N C VRTDI4 = VRTDI4 + 2. * EGT(I,IVTOR1,IVTORP) C & * (I - N - 0.5) C & * A1T4(I,IVTOR1,IVTORP) C & * (I - N - 1) * (I - N - 1) C*******DABK DERIVATIVE MADE HERMITIAN BY JTH 18 APR 92 VRTDI4 = VRTDI4 + 2. * EGT(I,IVTOR1,IVTORP) & * A1T4(I,IVTOR1,IVTORP) C & * (I - N - 0.5) C & * (I - N - 1) * (I - N - 1) & * 0.5*((I - N - 1)**3 + (I - N)**3) 7034 CONTINUE 7032 CONTINUE 7030 CONTINUE ELSE IF (PARA (LO, L) .EQ. 'DABJK ') THEN DO 8099 IVTORP = 1,9 DO 8098 IVTOR1 = 1,9 DO 8097 I = 1, 2 * N C*******DABK DERIVATIVE MADE HERMITIAN BY JTH 18 APR 92 VRTDI4 = VRTDI4 + 2. * EGT(I,IVTOR1,IVTORP) & * A1T4(I,IVTOR1,IVTORP) C & * (I - N - 0.5) C & * (I - N - 1) * (I - N - 1) & * 0.5*((I - N - 1)**3 + (I - N)**3) & *N*(N+1) 8097 CONTINUE 8098 CONTINUE 8099 CONTINUE ELSE IF (PARA (LO, L) .EQ. 'ODABK ')THEN DO 9030 IVTORP = 1,9 DO 9032 IVTOR1 = 1,9 DO 9034 I = 1, 2 * N VRTDI4 = VRTDI4 + 2. * EGT(I,IVTOR1,IVTORP) & * (A1T4(I,IVTOR1,IVTORP) & - 0.5 * (A2T4(I,IVTOR1,IVTORP) & + A3T4(I,IVTOR1,IVTORP))) & * 0.5*((I - N - 1)**3 + (I - N)**3) 9034 CONTINUE 9032 CONTINUE 9030 CONTINUE ELSE IF (PARA (LO, L) .EQ. 'ODABJK ')THEN DO 9039 IVTORP = 1,9 DO 9038 IVTOR1 = 1,9 DO 9037 I = 1, 2 * N VRTDI4 = VRTDI4 + 2. * EGT(I,IVTOR1,IVTORP) & * (A1T4(I,IVTOR1,IVTORP) & - 0.5 * (A2T4(I,IVTOR1,IVTORP) & + A3T4(I,IVTOR1,IVTORP))) & *(N*(N+1)) & * 0.5*((I - N - 1)**3 + (I - N)**3) 9037 CONTINUE 9038 CONTINUE 9039 CONTINUE ELSE IF (PARA (LO, L) .EQ. 'DACK ') THEN DO 9070 IVTORP = 1,9 DO 9072 IVTOR1 = 1,9 DO 9074 I = 1, 2 * N VRTDI4 = VRTDI4 + EGT(I,IVTOR1,IVTORP) & * 0.5*((I - N - 1)**3 + (I - N)**3) & * (A3T4(I,IVTOR1,IVTORP) - A4T4(I,IVTOR1,IVTORP)) 9074 CONTINUE 9072 CONTINUE 9070 CONTINUE ELSE IF (PARA (LO, L) .EQ. 'DAC ') THEN DO 7040 IVTORP = 1,9 DO 7042 IVTOR1 = 1,9 DO 7044 I = 1, 2 * N C ********I BELIEVE THERE IS AN EXTRA FACTOR OF 2 IN THE NEXT LINE, AND C ********I HAVE REMOVED IT C ********VRTDIS4=VRTDIS4+2.*EG*SQ*(K+0.5)*(-1.)*(A4-A3) VRTDI4 = VRTDI4 + EGT(I,IVTOR1,IVTORP) & * (I - N - 0.5) & * (A3T4(I,IVTOR1,IVTORP) - A4T4(I,IVTOR1,IVTORP)) 7044 CONTINUE 7042 CONTINUE 7040 CONTINUE ELSE IF (PARA (LO, L) .EQ. 'DACJ ') THEN DO 9040 IVTORP = 1,9 DO 9042 IVTOR1 = 1,9 DO 9044 I = 1, 2 * N VRTDI4 = VRTDI4 + EGT(I,IVTOR1,IVTORP) & * (I - N - 0.5) & *(N*(N+1)) & * (A3T4(I,IVTOR1,IVTORP) - A4T4(I,IVTOR1,IVTORP)) 9044 CONTINUE 9042 CONTINUE 9040 CONTINUE ELSE IF (PARA (LO, L) .EQ. 'DAC12 ') THEN DO 3040 IVTORP = 1,9 DO 3042 IVTOR1 = 1,9 DO 3044 I = 1, 2 * N VRTDI4 = VRTDI4 + EGT(I,IVTOR1,IVTORP) & * (I - N - 0.5) & * (A3T4B(I,IVTOR1,IVTORP) - A4T4B(I,IVTOR1,IVTORP)) 3044 CONTINUE 3042 CONTINUE 3040 CONTINUE ELSE IF (PARA (LO, L) .EQ. 'ODELTA') THEN DO 7050 IVTORP = 1,9 DO 7052 IVTOR1 = 1,9 DO 7054 I = 1, 2 * N VRTDI4 = VRTDI4 + EGT(I,IVTOR1,IVTORP) & * A5T4(I,IVTOR1,IVTORP) 7054 CONTINUE 7052 CONTINUE 7050 CONTINUE ELSE IF (PARA (LO, L) .EQ. 'DELTA ') THEN DO 7060 IVTORP = 1,9 DO 7062 IVTOR1 = 1,9 DO 7064 I = 1, 2 * N VRTDI4 = VRTDI4 + EGT(I,IVTOR1,IVTORP) & * A6T4(I,IVTOR1,IVTORP) 7064 CONTINUE 7062 CONTINUE 7060 CONTINUE * ELSE IF (PARA (LO, L) .EQ. 'ODELTB') THEN DO 8050 IVTORP = 1,9 DO 8052 IVTOR1 = 1,9 DO 8054 I = 1, 2 * N VRTDI4 = VRTDI4 + EGT(I,IVTOR1,IVTORP) & * A5T4B(I,IVTOR1,IVTORP) 8054 CONTINUE 8052 CONTINUE 8050 CONTINUE ELSE IF (PARA (LO, L) .EQ. 'DELTAB') THEN DO 8060 IVTORP = 1,9 DO 8062 IVTOR1 = 1,9 DO 8064 I = 1, 2 * N VRTDI4 = VRTDI4 + EGT(I,IVTOR1,IVTORP) & * A6T4B(I,IVTOR1,IVTORP) 8064 CONTINUE 8062 CONTINUE 8060 CONTINUE END IF * END C******************************************************************** FUNCTION VRTDI5 (L, LO) c my insertion IMPLICIT REAL*8 ( A-H,O-Z ) C IMPLICIT DOUBLE PRECISION (A - H, O - Z) C******************************************************************** C DERIVATIVES INVOLVING THE K/K MATRIX ELEMENTS OF THE C HAMILTONIAN BUT WITH THE SUM OVER THE A COEFICIENTS C (FV,OFV,GV,AK1-AK7,ALV,OLV) C CHARACTER*1 PR,PROBS CHARACTER * 6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1) COMMON / EIGEN / H(NDMX,NDMX),WORK(NDMX),EGVC3(KDMX,9),NBR(2) COMMON / CHARA / PARA (2,160), PR, PROBS (2,80000), REF (80000) COMMON / QUANT / ISIG, IV, N, KK * REAL*8 A1T1(KDMX,9,9), & A1T2(KDMX,9,9),A2T2(KDMX,9,9),A3T2(KDMX,9,9), & A4T2(KDMX,9,9),A5T2(KDMX,9,9),A7T2(KDMX,9,9), & A1T4(KDMX,9,9),A2T4(KDMX,9,9),A3T4(KDMX,9,9), & A4T4(KDMX,9,9),A5T4(KDMX,9,9),A6T4(KDMX,9,9), & A1T5(KDMX,9,9),A2T5(KDMX,9,9),A3T5(KDMX,9,9), & A4T5(KDMX,9,9),A5T5(KDMX,9,9), & A4T5B(KDMX,9,9),A5T5B(KDMX,9,9), & A4T5BB(KDMX,9,9),A5T5BB(KDMX,9,9), & A7T5(KDMX,9,9),A8T5(KDMX,9,9),A9T5(KDMX,9,9), & A10T5(KDMX,9,9),A11T5(KDMX,9,9),A12T5(KDMX,9,9), & A13T5(KDMX,9,9),A14T5(KDMX,9,9),A15T5(KDMX,9,9), & A16T5(KDMX,9,9),A17T5(KDMX,9,9), & A1TS(KDMX,9,9),A2TS(KDMX,9,9),A5TS(KDMX,9,9), & A8T2(KDMX,9,9),A9T2(KDMX,9,9), & A20T4(KDMX,9,9),A21T4(KDMX,9,9) & ,A8T5B(KDMX,9,9),A9T5B(KDMX,9,9), & A14T5B(KDMX,9,9),A15T5B(KDMX,9,9) & ,A5T4B(KDMX,9,9),A6T4B(KDMX,9,9) & ,A10T2(KDMX,9,9),A11T2(KDMX,9,9),A1T4B(KDMX,9,9) & ,A10T5B(KDMX,9,9),A11T5B(KDMX,9,9) & ,A16T5B(KDMX,9,9),A17T5B(KDMX,9,9) & ,A6TS(KDMX,9,9),A18T5(KDMX,9,9),A19T5(KDMX,9,9) & ,A3T4B(KDMX,9,9),A4T4B(KDMX,9,9),A4T2B(KDMX,9,9) & ,A5T2B(KDMX,9,9) & ,A20T5(KDMX,9,9),A21T5(KDMX,9,9) COMMON /VRTD/ A1T1,A1T2,A2T2,A3T2,A4T2,A5T2,A7T2, & A1T4,A2T4,A3T4,A4T4,A5T4,A6T4, & A1T5,A2T5,A3T5,A4T5,A5T5,A7T5,A8T5,A9T5, & A10T5,A11T5,A12T5,A13T5,A14T5,A15T5,A16T5,A17T5, & A1TS,A2TS,A5TS,A8T2,A9T2,A20T4,A21T4 & ,A8T5B,A9T5B,A14T5B,A15T5B & ,A4T5B,A5T5B,A5T4B,A6T4B,A4T5BB,A5T5BB & ,A10T2,A11T2,A1T4B,A10T5B,A11T5B,A16T5B,A17T5B & ,A6TS,A18T5,A19T5,A3T4B,A4T4B,A4T2B,A5T2B & ,A20T5,A21T5 * REAL*8 EGT(KDMX,9,9) * C PRINT*,'DANS VRRTDI5' DO 1004 IVTORP = 1,9 DO 1002 IVTOR1 = 1,9 DO 1000 I = 1, 2 * N + 1 EGT(I,IVTOR1,IVTORP) = EGVC3(I,IVTORP) * EGVC3(I,IVTOR1) 1000 CONTINUE 1002 CONTINUE 1004 CONTINUE * IF (PARA(LO,L).EQ.'FV ' .OR. PARA(LO,L).EQ.'OFV ') THEN VRTDIA = 0.0 DO 7006 IVTORP = 1,9 DO 7004 IVTOR1 = 1,9 DO 7003 I = 1, 2 * N + 1 VRTDIA = VRTDIA + EGT(I,IVTOR1,IVTORP) & * (A1T1(I,IVTOR1,IVTORP) & - 0.5*A7T5(I,IVTOR1,IVTORP) & - 0.5*A1T5(I,IVTOR1,IVTORP)) 7003 CONTINUE 7004 CONTINUE 7006 CONTINUE END IF * IF (PARA(LO,L).EQ.'GV ' .OR. PARA(LO,L).EQ.'GVJ ') THEN VRTDIB = 0.0 DO 7032 IVTORP = 1,9 DO 7030 IVTOR1 = 1,9 DO 7028 I = 1, 2 * N + 1 VRTDIB = VRTDIB + EGT(I,IVTOR1,IVTORP) & * A2T5(I,IVTOR1,IVTORP) 7028 CONTINUE 7030 CONTINUE 7032 CONTINUE END IF * IF (PARA(LO,L).EQ.'ALV '.OR.PARA(LO,L).EQ.'OLV ')THEN VRTDIC = 0.0 DO 7170 IVTORP = 1,9 DO 7168 IVTOR1 = 1,9 DO 7166 I = 1, 2 * N + 1 K = I - N - 1 VRTDIC = VRTDIC + EGT(I,IVTOR1,IVTORP) * K & * A3T5(I,IVTOR1,IVTORP) 7166 CONTINUE 7168 CONTINUE 7170 CONTINUE END IF * IF (PARA(LO,L).EQ.'AK1 ' .OR. PARA(LO,L).EQ.'AK1J '.OR. & PARA(LO,L).EQ.'AK1JJ ') THEN C & PARA(LO,L).EQ.'OLV ') THEN VRTDID = 0.0 DO 7048 IVTORP = 1,9 DO 7046 IVTOR1 = 1,9 DO 7044 I = 1, 2 * N + 1 K = I - N - 1 VRTDID = VRTDID + EGT(I,IVTOR1,IVTORP) * K * K * K & * A3T5(I,IVTOR1,IVTORP) 7044 CONTINUE 7046 CONTINUE 7048 CONTINUE END IF * IF (PARA(LO,L).EQ.'AK2 ' .OR. PARA(LO,L).EQ.'AK2J '.OR. & PARA(LO,L).EQ.'AK2JJ ') THEN VRTDIE = 0.0 DO 7072 IVTORP = 1,9 DO 7070 IVTOR1 = 1,9 DO 7068 I = 1, 2 * N + 1 K = I - N - 1 VRTDIE = VRTDIE + EGT(I,IVTOR1,IVTORP) * K * K & * A2T5(I,IVTOR1,IVTORP) 7068 CONTINUE 7070 CONTINUE 7072 CONTINUE END IF * IF (PARA(LO,L).EQ.'AK3 ' .OR. PARA(LO,L).EQ.'AK3J '.OR. & PARA(LO,L).EQ.'AK3JJ ') THEN VRTDIF = 0.0 DO 7096 IVTORP = 1,9 DO 7094 IVTOR1 = 1,9 DO 7092 I = 1, 2 * N + 1 K = I - N - 1 VRTDIF = VRTDIF + EGT(I,IVTOR1,IVTORP) * K & * A4T5(I,IVTOR1,IVTORP) 7092 CONTINUE 7094 CONTINUE 7096 CONTINUE END IF * IF (PARA(LO,L).EQ.'AK3K '.OR.PARA(LO,L).EQ.'AK3KJ ') THEN VRTDIZ = 0.0 DO 8096 IVTORP = 1,9 DO 8094 IVTOR1 = 1,9 DO 8092 I = 1, 2 * N + 1 K = I - N - 1 VRTDIZ = VRTDIZ + EGT(I,IVTOR1,IVTORP) * K**3 & * A4T5(I,IVTOR1,IVTORP) 8092 CONTINUE 8094 CONTINUE 8096 CONTINUE END IF * IF (PARA(LO,L).EQ.'AK3KK ') THEN VRTDIZ1= 0.0 DO 3096 IVTORP = 1,9 DO 3094 IVTOR1 = 1,9 DO 3092 I = 1, 2 * N + 1 K = I - N - 1 VRTDIZ1= VRTDIZ1+ EGT(I,IVTOR1,IVTORP) * K**5 & * A4T5(I,IVTOR1,IVTORP) 3092 CONTINUE 3094 CONTINUE 3096 CONTINUE END IF * IF (PARA(LO,L).EQ.'AK3B '.OR.PARA(LO,L).EQ.'AK3BJ ')THEN VRTDIQ = 0.0 DO 6096 IVTORP = 1,9 DO 6094 IVTOR1 = 1,9 DO 6092 I = 1, 2 * N + 1 K = I - N - 1 VRTDIQ = VRTDIQ + EGT(I,IVTOR1,IVTORP) * K & * A4T5B(I,IVTOR1,IVTORP) 6092 CONTINUE 6094 CONTINUE 6096 CONTINUE END IF * IF (PARA(LO,L).EQ.'AK3BB ')THEN VRTDIQ2= 0.0 DO 4096 IVTORP = 1,9 DO 4094 IVTOR1 = 1,9 DO 4092 I = 1, 2 * N + 1 K = I - N - 1 VRTDIQ2= VRTDIQ2+ EGT(I,IVTOR1,IVTORP) * K & * A4T5BB(I,IVTOR1,IVTORP) 4092 CONTINUE 4094 CONTINUE 4096 CONTINUE END IF * IF (PARA(LO,L).EQ.'AK4 ' .OR. PARA(LO,L).EQ.'AMV '.OR. & PARA(LO,L).EQ.'AMVJ ') THEN VRTDIG = 0.0 DO 7120 IVTORP = 1,9 DO 7118 IVTOR1 = 1,9 DO 7116 I = 1, 2 * N + 1 VRTDIG = VRTDIG + EGT(I,IVTOR1,IVTORP) & * A5T5(I,IVTOR1,IVTORP) 7116 CONTINUE 7118 CONTINUE 7120 CONTINUE END IF * IF (PARA(LO,L).EQ.'AK4B '.OR.PARA(LO,L).EQ.'AK4BJ ') THEN VRTDIY = 0.0 DO 6120 IVTORP = 1,9 DO 6118 IVTOR1 = 1,9 DO 6116 I = 1, 2 * N + 1 VRTDIY = VRTDIY + EGT(I,IVTOR1,IVTORP) & * A5T5B(I,IVTOR1,IVTORP) 6116 CONTINUE 6118 CONTINUE 6120 CONTINUE END IF * IF (PARA(LO,L).EQ.'AK4BB ')THEN VRTDIY2= 0.0 DO 3120 IVTORP = 1,9 DO 3118 IVTOR1 = 1,9 DO 3116 I = 1, 2 * N + 1 VRTDIY2= VRTDIY2+ EGT(I,IVTOR1,IVTORP) & * A5T5BB(I,IVTOR1,IVTORP) 3116 CONTINUE 3118 CONTINUE 3120 CONTINUE END IF * C PRINT*,'PARA=',PARA(LO,L) IF (PARA(LO,L).EQ.'BK1 '.OR.PARA(LO,L).EQ.'BK1J ') THEN VRTDIX = 0.0 DO 7220 IVTORP = 1,9 DO 7218 IVTOR1 = 1,9 DO 7216 I = 1, 2 * N + 1 K=I-N-1 VRTDIX = VRTDIX + EGT(I,IVTOR1,IVTORP) & * A5T5(I,IVTOR1,IVTORP)*K**2 7216 CONTINUE 7218 CONTINUE 7220 CONTINUE END IF * IF (PARA(LO,L).EQ.'BK1K ') THEN VRTDIX1= 0.0 DO 3220 IVTORP = 1,9 DO 3218 IVTOR1 = 1,9 DO 3216 I = 1, 2 * N + 1 K=I-N-1 VRTDIX1= VRTDIX1+ EGT(I,IVTOR1,IVTORP) & * A5T5(I,IVTOR1,IVTORP)*K**4 3216 CONTINUE 3218 CONTINUE 3220 CONTINUE END IF * IF (PARA(LO,L).EQ.'AK5 ' .OR. PARA(LO,L).EQ.'AK5J ') THEN VRTDIH = 0.0 DO 7134 IVTORP = 1,9 DO 7133 IVTOR1 = 1,9 DO 7132 I = 1, 2 * N + 1 K = I - N - 1 VRTDIH = VRTDIH + EGT(I,IVTOR1,IVTORP) * K * K & * (A1T1(I,IVTOR1,IVTORP) & - 0.5*A7T5(I,IVTOR1,IVTORP) & - 0.5*A1T5(I,IVTOR1,IVTORP)) 7132 CONTINUE 7133 CONTINUE 7134 CONTINUE END IF * IF (PARA(LO,L).EQ.'AK7 '.OR.PARA(LO,L).EQ.'AK7J ')THEN VRTDIJ = 0.0 DO 7162 IVTORP = 1,9 DO 7161 IVTOR1 = 1,9 DO 7160 I = 1, 2 * N + 1 K = I - N - 1 VRTDIJ = VRTDIJ + EGT(I,IVTOR1,IVTORP) & * (A2T5(I,IVTOR1,IVTORP) & - 0.5*A10T5(I,IVTOR1,IVTORP) & - 0.5*A11T5(I,IVTOR1,IVTORP) & + A2T5(I,IVTOR1,IVTORP) & - 0.5*A16T5(I,IVTOR1,IVTORP) & - 0.5*A17T5(I,IVTOR1,IVTORP)) 7160 CONTINUE 7161 CONTINUE 7162 CONTINUE END IF * IF (PARA(LO,L).EQ.'AK9 ') THEN VRTDIJ1= 0.0 DO 2162 IVTORP = 1,9 DO 2161 IVTOR1 = 1,9 DO 2160 I = 1, 2 * N + 1 K = I - N - 1 VRTDIJ1= VRTDIJ1+ EGT(I,IVTOR1,IVTORP) & * (A2T5(I,IVTOR1,IVTORP) & - 0.5*A10T5B(I,IVTOR1,IVTORP) & - 0.5*A11T5B(I,IVTOR1,IVTORP) & + A2T5(I,IVTOR1,IVTORP) & - 0.5*A16T5B(I,IVTOR1,IVTORP) & - 0.5*A17T5B(I,IVTOR1,IVTORP)) 2160 CONTINUE 2161 CONTINUE 2162 CONTINUE END IF * IF (PARA(LO,L).EQ.'AK7K ') THEN VRTDIV = 0.0 DO 8162 IVTORP = 1,9 DO 8161 IVTOR1 = 1,9 DO 8160 I = 1, 2 * N + 1 K = I - N - 1 VRTDIV = VRTDIV + EGT(I,IVTOR1,IVTORP)*K**2 & * (A2T5(I,IVTOR1,IVTORP) & - 0.5*A10T5(I,IVTOR1,IVTORP) & - 0.5*A11T5(I,IVTOR1,IVTORP) & + A2T5(I,IVTOR1,IVTORP) & - 0.5*A16T5(I,IVTOR1,IVTORP) & - 0.5*A17T5(I,IVTOR1,IVTORP)) 8160 CONTINUE 8161 CONTINUE 8162 CONTINUE ENDIF * IF (PARA(LO,L).EQ.'ANV '.OR.PARA(LO,L).EQ.'ANVJ ') THEN VRTDIK = 0.0 DO 7012 IVTORP = 1,9 DO 7011 IVTOR1 = 1,9 DO 7010 I = 1, 2 * N + 1 VRTDIK = VRTDIK + EGT(I,IVTOR1,IVTORP) & * (A1T1(I,IVTOR1,IVTORP) & - 0.5*A12T5(I,IVTOR1,IVTORP) & - 0.5*A13T5(I,IVTOR1,IVTORP)) 7010 CONTINUE 7011 CONTINUE 7012 CONTINUE END IF * IF (PARA(LO,L).EQ.'V12J ')THEN VRTDIK3= 0.0 DO 4012 IVTORP = 1,9 DO 4011 IVTOR1 = 1,9 DO 4010 I = 1, 2 * N + 1 VRTDIK3= VRTDIK3+ EGT(I,IVTOR1,IVTORP) & * (A1T1(I,IVTOR1,IVTORP) & - 0.5*A18T5(I,IVTOR1,IVTORP) & - 0.5*A19T5(I,IVTOR1,IVTORP)) 4010 CONTINUE 4011 CONTINUE 4012 CONTINUE END IF IF (PARA(LO,L).EQ.'V9J ')THEN VRTDIK5= 0.0 DO 5012 IVTORP = 1,9 DO 5011 IVTOR1 = 1,9 DO 5010 I = 1, 2 * N + 1 VRTDIK5= VRTDIK5+ EGT(I,IVTOR1,IVTORP) & * (A1T1(I,IVTOR1,IVTORP) & - 0.5*A20T5(I,IVTOR1,IVTORP) & - 0.5*A21T5(I,IVTOR1,IVTORP)) 5010 CONTINUE 5011 CONTINUE 5012 CONTINUE ENDIF IF (PARA(LO,L).EQ.'V9K ')THEN VRTDIK6= 0.0 DO 6012 IVTORP = 1,9 DO 6011 IVTOR1 = 1,9 DO 6010 I = 1, 2 * N + 1 K = I - N - 1 VRTDIK6= VRTDIK6+ EGT(I,IVTOR1,IVTORP) & * (A1T1(I,IVTOR1,IVTORP) & - 0.5*A20T5(I,IVTOR1,IVTORP) & - 0.5*A21T5(I,IVTOR1,IVTORP)) & *(K**2) 6010 CONTINUE 6011 CONTINUE 6012 CONTINUE ENDIF * IF (PARA(LO,L).EQ.'V12K ')THEN VRTDIK4= 0.0 DO 4015 IVTORP = 1,9 DO 4014 IVTOR1 = 1,9 DO 4013 I = 1, 2 * N + 1 K = I - N - 1 VRTDIK4= VRTDIK4+ EGT(I,IVTOR1,IVTORP) & * (A1T1(I,IVTOR1,IVTORP) & - 0.5*A18T5(I,IVTOR1,IVTORP) & - 0.5*A19T5(I,IVTOR1,IVTORP)) & *(K**2) 4013 CONTINUE 4014 CONTINUE 4015 CONTINUE END IF * IF (PARA(LO,L).EQ.'BK2 '.OR.PARA(LO,L).EQ.'BK2J ') THEN VRTDIL = 0.0 DO 7018 IVTORP = 1,9 DO 7017 IVTOR1 = 1,9 DO 7016 I = 1, 2 * N + 1 K = I - N - 1 VRTDIL = VRTDIL + EGT(I,IVTOR1,IVTORP) * K * K & * (A1T1(I,IVTOR1,IVTORP) & - 0.5*A12T5(I,IVTOR1,IVTORP) & - 0.5*A13T5(I,IVTOR1,IVTORP)) 7016 CONTINUE 7017 CONTINUE 7018 CONTINUE END IF * IF (PARA(LO,L).EQ.'AK6 '.OR.PARA(LO,L).EQ.'AK6K '.OR. 1 PARA(LO,L).EQ.'AK6J ') THEN VRTDIM = 0.0 VRTDIU = 0.0 DO 7154 IVTORP = 1,9 DO 7153 IVTOR1 = 1,9 DO 7152 I = 1, 2 * N + 1 K = I - N - 1 VRTDIM = VRTDIM + EGT(I,IVTOR1,IVTORP) * K & * (A3T5(I,IVTOR1,IVTORP) & - 0.5*A8T5(I,IVTOR1,IVTORP) & - 0.5*A9T5(I,IVTOR1,IVTORP) & + A3T5(I,IVTOR1,IVTORP) & - 0.5*A14T5(I,IVTOR1,IVTORP) & - 0.5*A15T5(I,IVTOR1,IVTORP)) VRTDIU = VRTDIU + EGT(I,IVTOR1,IVTORP)*K**2*K & * (A3T5(I,IVTOR1,IVTORP) & - 0.5*A8T5(I,IVTOR1,IVTORP) & - 0.5*A9T5(I,IVTOR1,IVTORP) & + A3T5(I,IVTOR1,IVTORP) & - 0.5*A14T5(I,IVTOR1,IVTORP) & - 0.5*A15T5(I,IVTOR1,IVTORP)) 7152 CONTINUE 7153 CONTINUE 7154 CONTINUE END IF * IF (PARA(LO,L).EQ.'AK66 ') THEN VRTDIW = 0.0 DO 9154 IVTORP = 1,9 DO 9153 IVTOR1 = 1,9 DO 9152 I = 1, 2 * N + 1 K = I - N - 1 VRTDIW = VRTDIW + EGT(I,IVTOR1,IVTORP) * K & * (A3T5(I,IVTOR1,IVTORP) & - 0.5*A8T5B(I,IVTOR1,IVTORP) & - 0.5*A9T5B(I,IVTOR1,IVTORP) & + A3T5(I,IVTOR1,IVTORP) & - 0.5*A14T5B(I,IVTOR1,IVTORP) & - 0.5*A15T5B(I,IVTOR1,IVTORP)) 9152 CONTINUE 9153 CONTINUE 9154 CONTINUE END IF * IF (PARA(LO,L).EQ.'AK5K ') THEN VRTDIN = 0.0 DO 7146 IVTORP = 1,9 DO 7145 IVTOR1 = 1,9 DO 7144 I = 1, 2 * N + 1 K = I - N - 1 VRTDIN = VRTDIN + EGT(I,IVTOR1,IVTORP) * K * K * K * K & * (A1T1(I,IVTOR1,IVTORP) & - 0.5*A7T5(I,IVTOR1,IVTORP) & - 0.5*A1T5(I,IVTOR1,IVTORP)) 7144 CONTINUE 7145 CONTINUE 7146 CONTINUE END IF * IF (PARA(LO,L).EQ.'AK2K '.OR.PARA(LO,L).EQ.'AK2JK ') THEN VRTDIO = 0.0 DO 7080 IVTORP = 1,9 DO 7078 IVTOR1 = 1,9 DO 7076 I = 1, 2 * N + 1 K = I - N - 1 VRTDIO = VRTDIO + EGT(I,IVTOR1,IVTORP) * K * K * K * K & * A2T5(I,IVTOR1,IVTORP) 7076 CONTINUE 7078 CONTINUE 7080 CONTINUE END IF * IF (PARA(LO,L).EQ.'AK1K '.OR.PARA(LO,L).EQ.'AK1JK ') THEN VRTDIP = 0.0 DO 7064 IVTORP = 1,9 DO 7062 IVTOR1 = 1,9 DO 7060 I = 1, 2 * N + 1 K = I - N - 1 VRTDIP = VRTDIP + EGT(I,IVTOR1,IVTORP) * (K ** 5) & * A3T5(I,IVTOR1,IVTORP) 7060 CONTINUE 7062 CONTINUE 7064 CONTINUE END IF * IF (PARA(LO,L).EQ.'FV ') THEN VRTDI5 = VRTDIA * N*(N+1) ELSE IF (PARA(LO,L).EQ.'ANV ') THEN VRTDI5 = VRTDIK * N*(N+1) ELSE IF (PARA(LO,L).EQ.'V12J ') THEN VRTDI5 = VRTDIK3* N*(N+1) ELSE IF (PARA(LO,L).EQ.'V12K ') THEN VRTDI5= VRTDIK4 ELSE IF (PARA(LO,L).EQ.'V9J ') THEN VRTDI5 = VRTDIK5* N*(N+1) ELSE IF (PARA(LO,L).EQ.'V9K ') THEN VRTDI5= VRTDIK6 ELSE IF (PARA(LO,L).EQ.'ANVJ ') THEN VRTDI5 = VRTDIK * N*(N+1)*N*(N+1) ELSE IF (PARA(LO,L).EQ.'BK2 ') THEN VRTDI5 = VRTDIL ELSE IF (PARA(LO,L).EQ.'BK2J ') THEN VRTDI5 = VRTDIL*N*(N+1) ELSE IF (PARA(LO,L).EQ.'OFV ') THEN VRTDI5 = VRTDIA * N*(N+1) * N*(N+1) ELSE IF (PARA(LO,L).EQ.'GV ') THEN VRTDI5 = VRTDIB * N*(N+1) ELSE IF (PARA(LO,L).EQ.'GVJ ') THEN VRTDI5 = VRTDIB * N*(N+1) * N*(N+1) ELSE IF (PARA(LO,L).EQ.'AK1 ') THEN VRTDI5 = VRTDID ELSE IF (PARA(LO,L).EQ.'AK1J ') THEN VRTDI5 = VRTDID * N*(N+1) ELSE IF (PARA(LO,L).EQ.'AK1JJ ') THEN VRTDI5 = VRTDID * N*(N+1)*N*(N+1) ELSE IF (PARA(LO,L).EQ.'AK1K ') THEN VRTDI5 = VRTDIP ELSE IF (PARA(LO,L).EQ.'AK1JK ') THEN VRTDI5 = VRTDIP *N*(N+1) ELSE IF (PARA(LO,L).EQ.'AK2 ') THEN VRTDI5 = VRTDIE ELSE IF (PARA(LO,L).EQ.'AK2K ') THEN VRTDI5 = VRTDIO ELSE IF (PARA(LO,L).EQ.'AK2JK ') THEN VRTDI5 = VRTDIO *N*(N+1) ELSE IF (PARA(LO,L).EQ.'AK2J ') THEN VRTDI5 = VRTDIE * N*(N+1) ELSE IF (PARA(LO,L).EQ.'AK2JJ ') THEN VRTDI5 = VRTDIE * N*(N+1)*N*(N+1) ELSE IF (PARA(LO,L).EQ.'AK3 ') THEN VRTDI5 = VRTDIF ELSE IF (PARA(LO,L).EQ.'AK3B ') THEN VRTDI5 = VRTDIQ ELSE IF (PARA(LO,L).EQ.'AK3BB ') THEN VRTDI5 = VRTDIQ2 ELSE IF (PARA(LO,L).EQ.'AK3BJ ') THEN VRTDI5 = VRTDIQ*N*(N+1) ELSE IF (PARA(LO,L).EQ.'AK3J ') THEN VRTDI5 = VRTDIF * N*(N+1) ELSE IF (PARA(LO,L).EQ.'AK3JJ ') THEN VRTDI5 = VRTDIF * N*(N+1)*N*(N+1) ELSE IF (PARA(LO,L).EQ.'AK3K ') THEN * Probleme : K * K ,problem solved (30 janvier 92) VRTDI5 = VRTDIZ ELSE IF (PARA(LO,L).EQ.'AK3KK ') THEN VRTDI5 = VRTDIZ1 ELSE IF (PARA(LO,L).EQ.'AK3KJ ') THEN VRTDI5 = VRTDIZ*N*(N+1) ELSE IF (PARA(LO,L).EQ.'AK4 ') THEN VRTDI5 = VRTDIG ELSE IF (PARA(LO,L).EQ.'AK4B ') THEN VRTDI5 = VRTDIY ELSE IF (PARA(LO,L).EQ.'AK4BB ') THEN VRTDI5 = VRTDIY2 ELSE IF (PARA(LO,L).EQ.'AK4BJ ') THEN VRTDI5 = VRTDIY*N*(N+1) ELSE IF (PARA(LO,L).EQ.'AMV ') THEN VRTDI5 = VRTDIG * N*(N+1) ELSE IF (PARA(LO,L).EQ.'AMVJ ') THEN VRTDI5 = VRTDIG * N*(N+1)*N*(N+1) ELSE IF (PARA(LO,L).EQ.'AK5 ') THEN VRTDI5 = VRTDIH ELSE IF (PARA(LO,L).EQ.'AK5J ') THEN VRTDI5 = VRTDIH * N*(N+1) ELSE IF (PARA(LO,L).EQ.'AK5K ') THEN VRTDI5 = VRTDIN ELSE IF (PARA(LO,L).EQ.'AK6 ') THEN VRTDI5 = VRTDIM ELSE IF (PARA(LO,L).EQ.'AK6J ') THEN VRTDI5 = VRTDIM*N*(N+1) ELSE IF (PARA(LO,L).EQ.'AK66 ') THEN VRTDI5 = VRTDIW ELSE IF (PARA(LO,L).EQ.'AK6K ') THEN VRTDI5 =VRTDIU ELSE IF (PARA(LO,L).EQ.'AK7 ') THEN VRTDI5 = VRTDIJ ELSE IF (PARA(LO,L).EQ.'AK9 ') THEN VRTDI5 = VRTDIJ1 ELSE IF (PARA(LO,L).EQ.'AK7K ') THEN VRTDI5 = VRTDIV ELSE IF (PARA(LO,L).EQ.'AK7J ') THEN VRTDI5 = VRTDIJ*N*(N+1) ELSE IF (PARA(LO,L).EQ.'BK1 ') THEN VRTDI5 = VRTDIX ELSE IF (PARA(LO,L).EQ.'BK1K ') THEN VRTDI5 = VRTDIX1 ELSE IF (PARA(LO,L).EQ.'BK1J ') THEN VRTDI5 = VRTDIX*N*(N+1) C PRINT*,'VRTDIX=',VRTDIX ELSE IF (PARA(LO,L).EQ.'ALV ') THEN VRTDI5 = VRTDIC * N*(N+1) ELSE IF (PARA(LO,L).EQ.'OLV ') THEN VRTDI5 = VRTDIC * N*(N+1)*N*(N+1) END IF END C************************************************************** FUNCTION VRTDI6 (L,CST,LO,A) IMPLICIT REAL*8 ( A-H,O-Z ) C************************************************************** C DERIVATIVES OF THE ELEMENTS OF THE MATRIX HAMILTONIAN C FOR THE RHO PARAMETER C THE DERIVATIVE FOR C4 IS MISSING HERE. C THIS SUBROUTINE IS NOT USEFUL ANYMORE SINCE THE ONLY RHO C TERM IS IN THE TORSIONAL HAMILTONIEN C CHARACTER ABC*702 CHARACTER*1 PR,PROBS CHARACTER*6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1) COMMON/EIGEN/H(NDMX,NDMX),WORK(NDMX),EGVC3(KDMX,9),NBR(2) COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRON1 , * IBGTME,IBGVTD ,EVIB(2),IRMW,TERM COMMON/ROTOR/NROTOR,NDIMTO COMMON/PAR/IND(2,80),NP(2),X(160),ITO COMMON/SYMB/ABC COMMON/CHARA/PARA(2,160),PR,PROBS(2,80000),REF(80000) COMMON/QUANT/ISIG,IV,N,KK DIMENSION CST(2,117),A(9,NTORMX,KDMX) RHO=CST(LO,102) C RHOJ=CST(LO,60) C RHOK=CST(LO,61) GV=CST(LO,18) ALV=CST(LO,19) AK1=CST(LO,20) AK2=CST(LO,21) AK3=CST(LO,22) AK4=CST(LO,23) AK5=CST(LO,24) AK6=CST(LO,25) AK7=CST(LO,26) C1=CST(LO,32) C3=CST(LO,34) C2J=CST(LO,37) GVJ=CST(LO,38) AK2J=CST(LO,39) C1J=CST(LO,40) AMV=CST(LO,43) VRTDIA =0.0 VRTDIB =0.0 DO 6 IVTORP=1,9 DO 7 I=1,2*N+1 K=I-N-1 A1=0.0 A2=0.0 A3=0.0 A4=0.00D0 DO 8 III=1,NDIMTO C RHOEFF=RHO+RHOJ*N*(N+1)+RHOK*K**2 RHOEFF=RHO RHOKSG =3.*(III-KTRON1)+ISIG+RHOEFF*K RHOKS1 =RHOKSG +3. IF (III.NE.NDIMTO ) THEN A4=A4+A(IVTORP,III,I)*A(IVTORP,III+1,I) & *(RHOKSG+RHOKS1) ENDIF A1=A1+A(IVTORP,III,I)*A(IVTORP,III,I)*RHOKSG A2=A2+A(IVTORP,III,I)*A(IVTORP,III,I)*RHOKSG*RHOKSG A3=A3+A(IVTORP,III,I)*A(IVTORP,III,I)*RHOKSG*RHOKSG & *RHOKSG 8 CONTINUE EG=EGVC3(I,IVTORP)**2 VRTDIA =VRTDIA + EG*(2.*(GV+GVJ*N*(N+1))*K*A1+ * ALV*K**2)*N*(N+1) VRTDIA =VRTDIA +(AK1*K**4+2.*(AK2+AK2J*N*(N+1)) * *K**3*A1)*EG VRTDIA =VRTDIA +(3.*AK3*K**2*A2 + AK4*K*A3*4.+ * AMV*N*(N+1)*K*A3*4.)*EG VRTDIA =VRTDIA +(AK6*K**2 +AK7*2.*(K*A1-0.5*K*A4))*EG 7 CONTINUE 6 CONTINUE DO 9 IVTORP=1,9 DO 10 I=1,2*N-1 IPLUS2=I+2 K=I-N-1 DO 11 IVTOR1 =1,9 A1=0.0 A2=0.0 DO 12 III=1,NDIMTO RHOKSG =3.*(III-KTRON1)+ISIG+RHOEFF*K RHOKS1 =RHOKSG +2.*RHOEFF A1=A1+A(IVTORP,III,I)*A(IVTOR1,III,IPLUS2) & *(K*RHOKSG +(K+2)*RHOKS1 ) A2=A2+A(IVTORP,III,I)*A(IVTOR1,III,IPLUS2) & *(2.*K*(RHOKSG **3)+2.*(K+2)*(RHOKS1 **3)) 12 CONTINUE ANN=FLOAT((N*(N+1)-K*(K+1))*(N*(N+1)-(K+1)*(K+2))) SQ=SQRT(ANN) VRTDIB =VRTDIB +EGVC3(I,IVTORP)*EGVC3(IPLUS2,IVTOR1 ) * *SQ*(C1*A1+C3*A2+C1J*A1*N*(N+1)) 11 CONTINUE 10 CONTINUE 9 CONTINUE VRTDI6 = VRTDIA + VRTDIB RETURN END C********************************************************** SUBROUTINE VSET(LO,V,CST) IMPLICIT REAL*8 ( A-H,O-Z ) C************************************************************ C SETS UP THE V MATRIX FOR EACH PARAMETER TO BE FITTED BY C TAKING THE DERIVATIVE OF THE ENERGY C THIS SUBROUTINE IS NOW ONLY CALCULATING THE DERIVATIVES AND C DOES NOT CALL ROTTOR(=DIAG. OF THE MATRICES AND ENERGY CALC.) C CHARACTER ABC*702 CHARACTER*6 PARA,REF CHARACTER*1 PROBS CHARACTER*1 PR PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1) COMMON/EIGEN/H(NDMX,NDMX),WORK(NDMX),EGVC3(KDMX,9),NBR(2) COMMON/EIGEN1/EGVL(2*NDMX),EGVC(NDMX,2*NDMX) COMMON/TOR/A(9,NTORMX,2*KDMX),ETOR(2*KDMX,9) COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRON1 , * IBGTME,IBGVTD ,EVIB(2),IRMW,TERM COMMON/ROTOR/NROTOR,NDIMTO COMMON/PAR/IND(2,80),NP(2),X(160),ITO COMMON/BIG2/DERIV1(10,961,80),ENER(10,961) COMMON/CHARA/PARA(2,160),PR,PROBS(2,80000),REF(80000) COMMON/EXPDAT / ETRANS(80000),IVOBS(2,80000), * NOBS(2,80000),KOBS(2,80000),IBLK(2,80000),IW(80000),W(80000), * NDATA,NADAT,EPSI,NOFIT,NFITMW,NFITIR,NFIMW0 ,NFIMW1 ,NITT, * IAST(80000),NFI004 ,NFI080 ,NFI100 ,NFI020 ,NFI200 ,NFI045 , & NGST0 ,NFI010 ,SW070,NFI070 ,NFIMW2,IKAKC,JMAX,NFI1M0, & NFIR10,NFIR21,NFIR32,NFIMW3,NFIMW4,SWA,SWE,NFITMWA,NFITMWE COMMON/SYMB/ABC COMMON/QUANT/ISIG,IV,N,KK DIMENSION CST(2,117),IBLSTO(2),V(160) * REAL*8 R2A(NTORMX,KDMX),R2B(NTORMX,KDMX),R2C(NTORMX,KDMX), & R2D(NTORMX,KDMX), & R4A(NTORMX,KDMX),R4B(NTORMX,KDMX), & R4AB(NTORMX,KDMX),R4BB(NTORMX,KDMX), & R5A(NTORMX,KDMX),R5B(NTORMX,KDMX),R5C(NTORMX,KDMX), & R5B2(NTORMX,KDMX),R5C2(NTORMX,KDMX), & R5B3(NTORMX,KDMX),R5C3(NTORMX,KDMX), & R5D(NTORMX,KDMX),R5E(NTORMX,KDMX),R5F(NTORMX,KDMX), & R5DD(NTORMX,KDMX),R5FF(NTORMX,KDMX), & R5G(NTORMX,KDMX),R5GG(NTORMX,KDMX), & RVA(NTORMX,KDMX),RVB(NTORMX,KDMX), & R2E(NTORMX,KDMX),R2F(NTORMX,KDMX),R5EE(NTORMX,KDMX) * REAL*8 A1T1(KDMX,9,9), & A1T2(KDMX,9,9),A2T2(KDMX,9,9),A3T2(KDMX,9,9), & A4T2(KDMX,9,9),A5T2(KDMX,9,9),A7T2(KDMX,9,9), & A1T4(KDMX,9,9),A2T4(KDMX,9,9),A3T4(KDMX,9,9), & A4T4(KDMX,9,9),A5T4(KDMX,9,9),A6T4(KDMX,9,9), & A1T5(KDMX,9,9),A2T5(KDMX,9,9),A3T5(KDMX,9,9), & A4T5(KDMX,9,9),A5T5(KDMX,9,9), & A4T5B(KDMX,9,9),A5T5B(KDMX,9,9), & A4T5BB(KDMX,9,9),A5T5BB(KDMX,9,9), & A7T5(KDMX,9,9),A8T5(KDMX,9,9),A9T5(KDMX,9,9), & A10T5(KDMX,9,9),A11T5(KDMX,9,9),A12T5(KDMX,9,9), & A13T5(KDMX,9,9),A14T5(KDMX,9,9),A15T5(KDMX,9,9), & A16T5(KDMX,9,9),A17T5(KDMX,9,9), & A1TS(KDMX,9,9),A2TS(KDMX,9,9),A5TS(KDMX,9,9), & A8T2(KDMX,9,9),A9T2(KDMX,9,9), & A20T4(KDMX,9,9),A21T4(KDMX,9,9) & ,A8T5B(KDMX,9,9),A9T5B(KDMX,9,9), & A14T5B(KDMX,9,9),A15T5B(KDMX,9,9) & ,A5T4B(KDMX,9,9),A6T4B(KDMX,9,9) & ,A10T2(KDMX,9,9),A11T2(KDMX,9,9),A1T4B(KDMX,9,9) & ,A10T5B(KDMX,9,9),A11T5B(KDMX,9,9) & ,A16T5B(KDMX,9,9),A17T5B(KDMX,9,9) & ,A6TS(KDMX,9,9),A18T5(KDMX,9,9),A19T5(KDMX,9,9) & ,A3T4B(KDMX,9,9),A4T4B(KDMX,9,9),A4T2B(KDMX,9,9) & ,A5T2B(KDMX,9,9) & ,A20T5(KDMX,9,9),A21T5(KDMX,9,9) COMMON /VRTD/ A1T1,A1T2,A2T2,A3T2,A4T2,A5T2,A7T2, & A1T4,A2T4,A3T4,A4T4,A5T4,A6T4, & A1T5,A2T5,A3T5,A4T5,A5T5,A7T5,A8T5,A9T5, & A10T5,A11T5,A12T5,A13T5,A14T5,A15T5,A16T5,A17T5, & A1TS,A2TS,A5TS,A8T2,A9T2,A20T4,A21T4 & ,A8T5B,A9T5B,A14T5B,A15T5B & ,A4T5B,A5T5B,A5T4B,A6T4B,A4T5BB,A5T5BB & ,A10T2,A11T2,A1T4B,A10T5B,A11T5B,A16T5B,A17T5B & ,A6TS,A18T5,A19T5,A3T4B,A4T4B,A4T2B,A5T2B & ,A20T5,A21T5 * C DEFINITION OF N,IV,KK,PR,ISIG CORRESPONDING TO THE CURRENT C DATA K AND TO 1 STATE C C N=NOBS(LO,K) C IV=IVOBS(LO,K) C KK=KOBS(LO,K) C PR=PROBS(LO,K) C IF(K.GT.NADAT) THEN C ISIG=1 C ELSE C ISIG=0 C ENDIF * IF(LO.EQ.1) THEN NI=1 M=1 ELSE NI=NDMX+1 M=KDMX+1 END IF * LOO=LO IF(IRMW.EQ.1.AND.LO.EQ.2) LO=1 IF(LO.EQ.1) THEN NA=1 NB=NP(1) ELSE NA=NP(1)+1 NB=NP(1)+NP(2) PRINT*,' NA= ',NA,' NB= ',NB END IF * C IBLK:DNUMBER OF THE N BLOCK C FROM HERE,THE MATRIX EGVC,EGVL,A,ETOR WILL BE SPLITTED C INTO 2 PARTS,ONE FOR THE LOWER STATE(LO=1),ONE FOR THE C UPPER STATE(LO=2) C IF(IBLK(LOO,K).NE.IBLSTO(LOO)) THEN C IBLSTO(LOO)=IBLK(LOO,K) C WRITE(6,*) ' K = ',K,'; N = ',N C CALL ROTTOR(CST,LO,EGVL(NI),EGVC(1,NI),ETOR(M,1) C 1 ,A(1,1,M)) C ENDIF C NROTOR=(2*N+1)*7 C CALL ENCAL(E,LOO,EGVL(NI),EGVC(1,NI)) C SUBROUTINE ENCAL TAKES THE GOOD EIGENVALUE AND EIGENVECT. C CORRESPONDING TO THE K CURRENT DATA C DO LOOP ON THE PARAMETER L TO BE FITTED C RHO=CST(LO,102) F=CST(LO,101) RHORHO=CST(LO,107) * DO 50 IVTORP = 1,9 DO 60 IVTOR1 = 1,9 DO 70 I = 1, 2 * N + 1 A1T1(I,IVTOR1,IVTORP) = 0.0 A1T2(I,IVTOR1,IVTORP) = 0.0 A2T2(I,IVTOR1,IVTORP) = 0.0 A3T2(I,IVTOR1,IVTORP) = 0.0 A4T2(I,IVTOR1,IVTORP) = 0.0 A4T2B(I,IVTOR1,IVTORP) = 0.0 A5T2(I,IVTOR1,IVTORP) = 0.0 A5T2B(I,IVTOR1,IVTORP) = 0.0 A7T2(I,IVTOR1,IVTORP) = 0.0 A8T2(I,IVTOR1,IVTORP) = 0.0 A9T2(I,IVTOR1,IVTORP) = 0.0 A10T2(I,IVTOR1,IVTORP) = 0.0 A11T2(I,IVTOR1,IVTORP) = 0.0 A1T4(I,IVTOR1,IVTORP) = 0.0 A1T4B(I,IVTOR1,IVTORP) = 0.0 A2T4(I,IVTOR1,IVTORP) = 0.0 A3T4(I,IVTOR1,IVTORP) = 0.0 A3T4B(I,IVTOR1,IVTORP) = 0.0 A4T4(I,IVTOR1,IVTORP) = 0.0 A4T4B(I,IVTOR1,IVTORP) = 0.0 A5T4(I,IVTOR1,IVTORP) = 0.0 A5T4B(I,IVTOR1,IVTORP) = 0.0 A6T4(I,IVTOR1,IVTORP) = 0.0 A6T4B(I,IVTOR1,IVTORP) = 0.0 A20T4(I,IVTOR1,IVTORP) = 0.0 A21T4(I,IVTOR1,IVTORP) = 0.0 A1T5(I,IVTOR1,IVTORP) = 0.0 A2T5(I,IVTOR1,IVTORP) = 0.0 A3T5(I,IVTOR1,IVTORP) = 0.0 A4T5(I,IVTOR1,IVTORP) = 0.0 A4T5B(I,IVTOR1,IVTORP) = 0.0 A4T5BB(I,IVTOR1,IVTORP) = 0.0 A5T5(I,IVTOR1,IVTORP) = 0.0 A5T5B(I,IVTOR1,IVTORP) = 0.0 A5T5BB(I,IVTOR1,IVTORP) = 0.0 A7T5(I,IVTOR1,IVTORP) = 0.0 A8T5(I,IVTOR1,IVTORP) = 0.0 A8T5B(I,IVTOR1,IVTORP) = 0.0 A9T5(I,IVTOR1,IVTORP) = 0.0 A9T5B(I,IVTOR1,IVTORP) = 0.0 A10T5(I,IVTOR1,IVTORP) = 0.0 A10T5B(I,IVTOR1,IVTORP) = 0.0 A11T5(I,IVTOR1,IVTORP) = 0.0 A11T5B(I,IVTOR1,IVTORP) = 0.0 A12T5(I,IVTOR1,IVTORP) = 0.0 A13T5(I,IVTOR1,IVTORP) = 0.0 A14T5(I,IVTOR1,IVTORP) = 0.0 A14T5B(I,IVTOR1,IVTORP) = 0.0 A15T5(I,IVTOR1,IVTORP) = 0.0 A15T5B(I,IVTOR1,IVTORP) = 0.0 A16T5(I,IVTOR1,IVTORP) = 0.0 A16T5B(I,IVTOR1,IVTORP) = 0.0 A17T5(I,IVTOR1,IVTORP) = 0.0 A17T5B(I,IVTOR1,IVTORP) = 0.0 A18T5(I,IVTOR1,IVTORP) = 0.0 A19T5(I,IVTOR1,IVTORP) = 0.0 A20T5(I,IVTOR1,IVTORP) = 0.0 A21T5(I,IVTOR1,IVTORP) = 0.0 A1TS(I,IVTOR1,IVTORP) = 0.0 A2TS(I,IVTOR1,IVTORP) = 0.0 A5TS(I,IVTOR1,IVTORP) = 0.0 A6TS(I,IVTOR1,IVTORP) = 0.0 70 CONTINUE 60 CONTINUE 50 CONTINUE * DO 80 I = 1, 2 * N + 1 K = I - N - 1 DO 90 III = 1, NDIMTO RHOEFF = RHO R2A(III,I) = 3.*(III-KTRON1) + ISIG + RHOEFF*K R2X = 3.*(III-KTRON1) + ISIG + RHOEFF*(K+2) R2B(III,I) = R2A(III,I)*R2A(III,I) + R2X*R2X R2C(III,I) = R2A(III,I)**4 + R2X**4 R2D(III,I) = R2X*(K+2) + R2A(III,I)*K * R4X = 3.*(III-KTRON1) + ISIG + RHOEFF*(K+1) R4A(III,I) = R4X*(K+1)*(K+1)+R2A(III,I)*K*K R4AB(III,I) = R4X**3*(K+1)*(K+1)+R2A(III,I)**3*K*K R4B(III,I) = R2A(III,I)*R2A(III,I)*K + R4X*R4X*(K+1) R4BB(III,I) =(R2A(III,I))**4*K+(R4X)**4*(K+1) R2E(III,I)=R2A(III,I)**3*(K)+R2X**3*(K+2) R2F(III,I)=R2A(III,I)*K*(K+2)**2+R2X*(K+2) 1 *(K)**2 * R5A(III,I) = R2A(III,I)*R2A(III,I) R5B(III,I) = R2A(III,I)*R2A(III,I)*R2A(III,I) R5B2(III,I) = R2A(III,I)*R2A(III,I)*R5B(III,I) R5B3(III,I) = R2A(III,I)*R2A(III,I)*R5B2(III,I) R5C(III,I) = R2A(III,I)*R2A(III,I)*R2A(III,I)*R2A(III,I) R5C2(III,I) = R2A(III,I)*R2A(III,I)*R5C(III,I) R5C3(III,I) = R2A(III,I)*R2A(III,I)*R5C2(III,I) R5D(III,I) = 3.*(III-KTRON1+1) + ISIG + RHOEFF*K R5DD(III,I) = 3.*(III-KTRON1+2) + ISIG + RHOEFF*K R5E(III,I) = R5D(III,I)*R5D(III,I) R5EE(III,I) = R5DD(III,I)*R5DD(III,I) R5F(III,I) = 3.*(III-KTRON1-1) + ISIG + RHOEFF*K R5FF(III,I) = 3.*(III-KTRON1-2) + ISIG + RHOEFF*K R5G(III,I) = R5F(III,I)*R5F(III,I) R5GG(III,I) = R5FF(III,I)*R5FF(III,I) * c RVA(III,I) = 3.*(III-KTRON1) + ISIG + RHORHO*K ccik debug change of rho sign! RVA(III,I) = 3.*(III-KTRON1) + ISIG - RHORHO*K RVB(III,I) = RVA(III,I)*RVA(III,I) 90 CONTINUE 80 CONTINUE * DO 100 IVTORP = 1,9 DO 110 IVTOR1 = 1,9 DO 120 I = 1, 2 * N + 1 DO 130 III = 1, NDIMTO AAA = A(IVTORP,III,M-1+I)*A(IVTOR1,III,M-1+I) * Pour VRTDI1 A1T1(I,IVTOR1,IVTORP) = A1T1(I,IVTOR1,IVTORP) + AAA * Pour VRTDI2 AA2 = A(IVTORP,III,M-1+I)*A(IVTOR1,III,M+I+1) A1T2(I,IVTOR1,IVTORP) = A1T2(I,IVTOR1,IVTORP) + AA2 A2T2(I,IVTOR1,IVTORP) = A2T2(I,IVTOR1,IVTORP) & + AA2 * R2B(III,I) A3T2(I,IVTOR1,IVTORP) = A3T2(I,IVTOR1,IVTORP) & + AA2 * R2C(III,I) A7T2(I,IVTOR1,IVTORP) = A7T2(I,IVTOR1,IVTORP) & + AA2 * R2D(III,I) A10T2(I,IVTOR1,IVTORP) = A10T2(I,IVTOR1,IVTORP) & + AA2 * R2E(III,I) A11T2(I,IVTOR1,IVTORP) = A11T2(I,IVTOR1,IVTORP) & + AA2 * R2F(III,I) * Pour VRTDI4 AA4 = A(IVTORP,III,M-1+I)*A(IVTOR1,III,M+I) A1T4(I,IVTOR1,IVTORP) = A1T4(I,IVTOR1,IVTORP) + AA4 A1T4B(I,IVTOR1,IVTORP) = A1T4B(I,IVTOR1,IVTORP) + AA4 & *R5B(III,I) A5T4(I,IVTOR1,IVTORP) = A5T4(I,IVTOR1,IVTORP) & + AA4 * R4A(III,I) A5T4B(I,IVTOR1,IVTORP) = A5T4B(I,IVTOR1,IVTORP) & + AA4 * R4AB(III,I) A6T4(I,IVTOR1,IVTORP) = A6T4(I,IVTOR1,IVTORP) & + AA4 * R4B(III,I) A6T4B(I,IVTOR1,IVTORP) = A6T4B(I,IVTOR1,IVTORP) & + AA4 * R4BB(III,I) * Pour VRTDI5 A2T5(I,IVTOR1,IVTORP) = A2T5(I,IVTOR1,IVTORP) & + AAA * R5A(III,I) A3T5(I,IVTOR1,IVTORP) = A3T5(I,IVTOR1,IVTORP) & + AAA * R2A(III,I) A4T5(I,IVTOR1,IVTORP) = A4T5(I,IVTOR1,IVTORP) & + AAA * R5B(III,I) A4T5B(I,IVTOR1,IVTORP) = A4T5B(I,IVTOR1,IVTORP) & + AAA * R5B2(III,I) A4T5BB(I,IVTOR1,IVTORP) = A4T5BB(I,IVTOR1,IVTORP) & + AAA * R5B3(III,I) A5T5(I,IVTOR1,IVTORP) = A5T5(I,IVTOR1,IVTORP) & + AAA * R5C(III,I) A5T5B(I,IVTOR1,IVTORP) = A5T5B(I,IVTOR1,IVTORP) & + AAA * R5C2(III,I) A5T5BB(I,IVTOR1,IVTORP) = A5T5BB(I,IVTOR1,IVTORP) & + AAA * R5C3(III,I) * Pour VTORS A1TS(I,IVTOR1,IVTORP) = A1TS(I,IVTOR1,IVTORP) & + AAA * RVA(III,I) A2TS(I,IVTOR1,IVTORP) = A2TS(I,IVTOR1,IVTORP) & + AAA * RVB(III,I) 130 CONTINUE DO 140 III = 1, NDIMTO-1 * Pour VRTDI2 A4T2(I,IVTOR1,IVTORP) = A4T2(I,IVTOR1,IVTORP) & + A(IVTORP,III+1,M-1+I)*A(IVTOR1,III,M+I+1) A5T2(I,IVTOR1,IVTORP) = A5T2(I,IVTOR1,IVTORP) & + A(IVTORP,III,M-1+I)*A(IVTOR1,III+1,M+I+1) * Pour VRTDI4 A2T4(I,IVTOR1,IVTORP) = A2T4(I,IVTOR1,IVTORP) & + A(IVTORP,III+1,M-1+I)*A(IVTOR1,III,M+I) A3T4(I,IVTOR1,IVTORP) = A3T4(I,IVTOR1,IVTORP) & + A(IVTORP,III,M-1+I)*A(IVTOR1,III+1,M+I) * Pour VRTDI5 AA5 = A(IVTORP,III,M-1+I)*A(IVTOR1,III+1,M-1+I) A1T5(I,IVTOR1,IVTORP) = A1T5(I,IVTOR1,IVTORP) + AA5 A9T5(I,IVTOR1,IVTORP) = A9T5(I,IVTOR1,IVTORP) & + AA5 * R2A(III,I) A11T5(I,IVTOR1,IVTORP) = A11T5(I,IVTOR1,IVTORP) & + AA5 * R5A(III,I) A14T5(I,IVTOR1,IVTORP) = A14T5(I,IVTOR1,IVTORP) & + AA5 * R5D(III,I) A16T5(I,IVTOR1,IVTORP) = A16T5(I,IVTOR1,IVTORP) & + AA5 * R5E(III,I) 140 CONTINUE DO 190 III=1,NDIMTO-2 * Pour VRTDI2 A8T2(I,IVTOR1,IVTORP) = A8T2(I,IVTOR1,IVTORP) & + A(IVTORP,III+2,M-1+I)*A(IVTOR1,III,M+I+1) A9T2(I,IVTOR1,IVTORP) = A9T2(I,IVTOR1,IVTORP) & + A(IVTORP,III,M-1+I)*A(IVTOR1,III+2,M+I+1) * Pour VRTDI4 A20T4(I,IVTOR1,IVTORP) = A20T4(I,IVTOR1,IVTORP) & + A(IVTORP,III+2,M-1+I)*A(IVTOR1,III,M+I) A21T4(I,IVTOR1,IVTORP) = A21T4(I,IVTOR1,IVTORP) & + A(IVTORP,III,M-1+I)*A(IVTOR1,III+2,M+I) 190 CONTINUE DO 150 III = 2, NDIMTO * Pour VRTDI4 A4T4(I,IVTOR1,IVTORP) = A4T4(I,IVTOR1,IVTORP) & + A(IVTORP,III,M-1+I)*A(IVTOR1,III-1,M+I) * Pour VRTDI5 AA5 = A(IVTORP,III,M-1+I)*A(IVTOR1,III-1,M-1+I) A7T5(I,IVTOR1,IVTORP) = A7T5(I,IVTOR1,IVTORP) + AA5 A8T5(I,IVTOR1,IVTORP) = A8T5(I,IVTOR1,IVTORP) & + AA5 * R2A(III,I) A10T5(I,IVTOR1,IVTORP) = A10T5(I,IVTOR1,IVTORP) & + AA5 * R5A(III,I) A15T5(I,IVTOR1,IVTORP) = A15T5(I,IVTOR1,IVTORP) & + AA5 * R5F(III,I) A17T5(I,IVTOR1,IVTORP) = A17T5(I,IVTOR1,IVTORP) & + AA5 * R5G(III,I) 150 CONTINUE * Pour VRTDI5 DO 160 III = 1, NDIMTO-2 A12T5(I,IVTOR1,IVTORP) = A12T5(I,IVTOR1,IVTORP) & + A(IVTORP,III,M-1+I)*A(IVTOR1,III+2,M-1+I) AA5B= A(IVTORP,III,M-1+I)*A(IVTOR1,III+2,M-1+I) A9T5B(I,IVTOR1,IVTORP) = A9T5B(I,IVTOR1,IVTORP) & + AA5B* R2A(III,I) A14T5(I,IVTOR1,IVTORP) = A14T5(I,IVTOR1,IVTORP) & + AA5B* R5DD(III,I) A8T5B(I,IVTOR1,IVTORP) = A8T5B(I,IVTOR1,IVTORP) & + AA5B* R2A(III,I) A15T5B(I,IVTOR1,IVTORP) = A15T5B(I,IVTOR1,IVTORP) & + AA5B* R5FF(III,I) A11T5B(I,IVTOR1,IVTORP) = A11T5B(I,IVTOR1,IVTORP) & + AA5B* R5A(III,I) A16T5B(I,IVTOR1,IVTORP) = A16T5B(I,IVTOR1,IVTORP) & + AA5B* R5EE(III,I) 160 CONTINUE DO 260 III = 1, NDIMTO-4 A18T5(I,IVTOR1,IVTORP) = A18T5(I,IVTOR1,IVTORP) & + A(IVTORP,III,M-1+I)*A(IVTOR1,III+4,M-1+I) * C FOR SIN 12 alpha :III+4 C FOR sin9 alpha :III+3 C A3T4B(I,IVTOR1,IVTORP) = A3T4B(I,IVTOR1,IVTORP) C & + A(IVTORP,III,M-1+I)*A(IVTOR1,III+4,M+I) * C A4T2B and A5T2B for DBC12 :sin12 alpha commented out C A4T2B(I,IVTOR1,IVTORP) = A4T2B(I,IVTOR1,IVTORP) C & + A(IVTORP,III+4,M-1+I)*A(IVTOR1,III,M+I+1) C A5T2B(I,IVTOR1,IVTORP) = A5T2B(I,IVTOR1,IVTORP) C & + A(IVTORP,III,M-1+I)*A(IVTOR1,III+4,M+I+1) C * 260 CONTINUE DO 270 III = 5, NDIMTO A19T5(I,IVTOR1,IVTORP) = A19T5(I,IVTOR1,IVTORP) & + A(IVTORP,III,M-1+I)*A(IVTOR1,III-4,M-1+I) * C FOR DAC9: III-3; FOR DAC12 III-4 C A4T4B(I,IVTOR1,IVTORP) = A4T4B(I,IVTOR1,IVTORP) C & + A(IVTORP,III,M-1+I)*A(IVTOR1,III-4,M+I) * 270 CONTINUE DO 271 III=4, NDIMTO A21T5(I,IVTOR1,IVTORP) = A21T5(I,IVTOR1,IVTORP) & + A(IVTORP,III,M-1+I)*A(IVTOR1,III-3,M-1+I) 271 CONTINUE * Pour VRTDI5 DO 170 III = 3, NDIMTO A13T5(I,IVTOR1,IVTORP) = A13T5(I,IVTOR1,IVTORP) & + A(IVTORP,III,M-1+I)*A(IVTOR1,III-2,M-1+I) A10T5B(I,IVTOR1,IVTORP) = A10T5B(I,IVTOR1,IVTORP) & + A(IVTORP,III,M-1+I)*A(IVTOR1,III-2,M-1+I) & * R5A(III,I) A17T5B(I,IVTOR1,IVTORP) = A17T5B(I,IVTOR1,IVTORP) & + A(IVTORP,III,M-1+I)*A(IVTOR1,III-2,M-1+I) & * R5GG(III,I) 170 CONTINUE * C FOR DAC9: III-3; FOR DAC12 III-4 DO 171 III = 4, NDIMTO A4T4B(I,IVTOR1,IVTORP) = A4T4B(I,IVTOR1,IVTORP) & + A(IVTORP,III,M-1+I)*A(IVTOR1,III-3,M+I) 171 CONTINUE * * Pour VTORS DO 180 III = 1, NDIMTO-3 A5TS(I,IVTOR1,IVTORP) = A5TS(I,IVTOR1,IVTORP) & + A(IVTORP,III,M-1+I)*A(IVTOR1,III+3,M-1+I) A20T5(I,IVTOR1,IVTORP) =A20T5(I,IVTOR1,IVTORP) & + A(IVTORP,III,M-1+I)*A(IVTOR1,III+3,M-1+I) * C FOR SIN 12 alpha :III+4 C FOR sin9 alpha :III+3 A3T4B(I,IVTOR1,IVTORP) = A3T4B(I,IVTOR1,IVTORP) & + A(IVTORP,III,M-1+I)*A(IVTOR1,III+3,M+I) * C A4T2B and A5T2B for DBC12 :sin12 alpha commented out A4T2B(I,IVTOR1,IVTORP) = A4T2B(I,IVTOR1,IVTORP) & + A(IVTORP,III+3,M-1+I)*A(IVTOR1,III,M+I+1) A5T2B(I,IVTOR1,IVTORP) = A5T2B(I,IVTOR1,IVTORP) & + A(IVTORP,III,M-1+I)*A(IVTOR1,III+3,M+I+1) C * 180 CONTINUE DO 280 III = 1, NDIMTO-4 A6TS(I,IVTOR1,IVTORP) = A6TS(I,IVTOR1,IVTORP) & + A(IVTORP,III,M-1+I)*A(IVTOR1,III+4,M-1+I) 280 CONTINUE 120 CONTINUE 110 CONTINUE 100 CONTINUE * DO 1000 L=NA,NB C PRINT*,'PARA DANS VSET=',PARA(LO,L) V(L)=0.0 IF(PARA(LO,L).EQ.'OA '.OR.PARA(LO,L).EQ.'DJ '.OR. & PARA(LO,L).EQ.'DJK '.OR.PARA(LO,L).EQ.'DK '.OR. & PARA(LO,L).EQ.'HJ '.OR.PARA(LO,L).EQ.'HJK '.OR. & PARA(LO,L).EQ.'HKJ '.OR.PARA(LO,L).EQ.'HK '.OR. & PARA(LO,L).EQ.'HLKJ ') THEN V(L)=V(L)+VRTDI1(L,LO) ELSE IF(PARA(LO,L).EQ.'B '.OR.PARA(LO,L).EQ.'C ')THEN V(L)=V(L)+VRTDI1(L,LO)+VRTDI2(L,LO) ELSE IF(PARA(LO,L).EQ.'DAB '.OR.PARA(LO,L).EQ.'ODAB '.OR. & PARA(LO,L).EQ.'DABJ '.OR.PARA(LO,L).EQ.'DABK '.OR. & PARA(LO,L).EQ.'DABJJ '.OR.PARA(LO,L).EQ.'DABJK '.OR. & PARA(LO,L).EQ.'DAC '.OR.PARA(LO,L).EQ.'ODELTA'.OR. & PARA(LO,L).EQ.'DACJ '.OR.PARA(LO,L).EQ.'ODABJ '.OR. & PARA(LO,L).EQ.'ODABJJ'.OR.PARA(LO,L).EQ.'ODABJK'.OR. & PARA(LO,L).EQ.'DELTAB'.OR.PARA(LO,L).EQ.'ODELTB'.OR. & PARA(LO,L).EQ.'ESPOIR'.OR.PARA(LO,L).EQ.'DAC12 '.OR. & PARA(LO,L).EQ.'ODABK '.OR.PARA(LO,L).EQ.'DELTA '.OR. & PARA(LO,L).EQ.'ODAB6 '.OR.PARA(LO,L).EQ.'DACK ')THEN V(L)=V(L)+VRTDI4(L,LO) ELSE IF(PARA(LO,L).EQ.'ODELN '.OR.PARA(LO,L).EQ.'ODELK '.OR. & PARA(LO,L).EQ.'OHJ '.OR.PARA(LO,L).EQ.'OHJK '.OR. & PARA(LO,L).EQ.'OHK '.OR.PARA(LO,L).EQ.'C1 '.OR. & PARA(LO,L).EQ.'C2 '.OR.PARA(LO,L).EQ.'C3 '.OR. & PARA(LO,L).EQ.'C3J '.OR.PARA(LO,L).EQ.'C12J '.OR. & PARA(LO,L).EQ.'C11 '.OR.PARA(LO,L).EQ.'DBC12 '.OR. & PARA(LO,L).EQ.'C2J '.OR.PARA(LO,L).EQ.'C1J '.OR. & PARA(LO,L).EQ.'DBC '.OR.PARA(LO,L).EQ.'C4 '.OR. & PARA(LO,L).EQ.'DBCJ '.OR.PARA(LO,L).EQ.'C11J '.OR. & PARA(LO,L).EQ.'C4J '.OR.PARA(LO,L).EQ.'C1K '.OR. & PARA(LO,L).EQ.'C2K '.OR.PARA(LO,L).EQ.'C12 '.OR. & PARA(LO,L).EQ.'C4K '.OR.PARA(LO,L).EQ.'C11K ')THEN V(L)=V(L)+VRTDI2(L,LO) ELSE IF(PARA(LO,L).EQ.'FV '.OR.PARA(LO,L).EQ.'OFV '.OR. & PARA(LO,L).EQ.'GV '.OR.PARA(LO,L).EQ.'AK1 '.OR. & PARA(LO,L).EQ.'AK2 '.OR.PARA(LO,L).EQ.'AK3 '.OR. & PARA(LO,L).EQ.'AK4 '.OR.PARA(LO,L).EQ.'AK5 '.OR. & PARA(LO,L).EQ.'AK6 '.OR.PARA(LO,L).EQ.'AK7 '.OR. & PARA(LO,L).EQ.'AK6K '.OR.PARA(LO,L).EQ.'AK7K '.OR. & PARA(LO,L).EQ.'AK66 '.OR.PARA(LO,L).EQ.'AK6J '.OR. & PARA(LO,L).EQ.'ALV '.OR.PARA(LO,L).EQ.'OLV '.OR. & PARA(LO,L).EQ.'AK5J '.OR.PARA(LO,L).EQ.'GVJ '.OR. & PARA(LO,L).EQ.'AK2J '.OR.PARA(LO,L).EQ.'ANV '.OR. & PARA(LO,L).EQ.'BK2 '.OR.PARA(LO,L).EQ.'AMV '.OR. & PARA(LO,L).EQ.'BK1 '.OR.PARA(LO,L).EQ.'AK7J '.OR. & PARA(LO,L).EQ.'AK1J '.OR.PARA(LO,L).EQ.'AK5K '.OR. & PARA(LO,L).EQ.'AK2K '.OR.PARA(LO,L).EQ.'AK1K '.OR. & PARA(LO,L).EQ.'AK3B '.OR.PARA(LO,L).EQ.'AK4B '.OR. & PARA(LO,L).EQ.'ANVJ '.OR.PARA(LO,L).EQ.'AMVJ '.OR. & PARA(LO,L).EQ.'AK3JJ '.OR.PARA(LO,L).EQ.'BK1J '.OR. & PARA(LO,L).EQ.'BK2J '.OR.PARA(LO,L).EQ.'AK3KJ '.OR. & PARA(LO,L).EQ.'BK1K '.OR.PARA(LO,L).EQ.'AK3KK '.OR. & PARA(LO,L).EQ.'AK2JJ '.OR.PARA(LO,L).EQ.'AK1JJ '.OR. & PARA(LO,L).EQ.'AK2JK '.OR.PARA(LO,L).EQ.'AK1JK '.OR. & PARA(LO,L).EQ.'AK3BJ '.OR.PARA(LO,L).EQ.'AK4BJ '.OR. & PARA(LO,L).EQ.'AK3BB '.OR.PARA(LO,L).EQ.'AK4BB '.OR. & PARA(LO,L).EQ.'AK9 '.OR.PARA(LO,L).EQ.'V12J '.OR. & PARA(LO,L).EQ.'V12K '.OR. & PARA(LO,L).EQ.'AK3J '.OR.PARA(LO,L).EQ.'AK3K '.OR. & PARA(LO,L).EQ.'V9J '.OR.PARA(LO,L).EQ.'V9K ')THEN C PRINT*,'PARA BEFORE VRTDI5=',PARA(LO,L) V(L)=V(L)+VRTDI5(L,LO) C PRINT*,'PARA AFTER VRTDI5=',PARA(LO,L) C IF(N.EQ.1.AND.KK.EQ.1) THEN C PRINT*,'V=',V(L),'VRTDI5=',VRTDI5(L,LO),'KK=',KK,'IV=',IV C ENDIF ELSE IF(PARA(LO,L).EQ.'F '.OR.PARA(LO,L).EQ.'V3 '.OR. & PARA(LO,L).EQ.'V6 '.OR.PARA(LO,L).EQ.'V9 '.OR. & PARA(LO,L).EQ.'RHORHO'.OR.PARA(LO,L).EQ.'V12 ')THEN V(L)=V(L)+VTORS(L,CST,LO) C PRINT*,' A= ',A(1,1,M),' M= ',M C ELSE IF(PARA(LO,L).EQ.'RHO ' C & .OR.PARA(LO,L).EQ.'RHOJ '.OR. PARA(LO,L).EQ.'RHOK ')THEN ELSE IF(PARA(LO,L).EQ.'RHO ') THEN V(L)=V(L)+VTORS(L,CST,LO)+VRTDI6(L,CST,LO,A(1,1,M)) ENDIF 1000 CONTINUE END C************************************************************* FUNCTION VTORS (L, CST, LO) c my insertion IMPLICIT REAL*8 ( A-H,O-Z ) C IMPLICIT DOUBLE PRECISION (A - H, O - Z) C************************************************************* C DERIVATIVES OF THE MATRIX ELEMENTS FOR THE TOSION HAMILTONIAN C F,V3,V6,V9 C CHARACTER*1 PR,PROBS CHARACTER * 6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1) COMMON / EIGEN / H(NDMX,NDMX),WORK(NDMX),EGVC3(KDMX,9),NBR(2) COMMON / CHARA / PARA (2,160), PR, PROBS (2,80000), REF (80000) COMMON / QUANT / ISIG, IV, N, KK REAL*8 CST(2,117) * REAL*8 A1T1(KDMX,9,9), & A1T2(KDMX,9,9),A2T2(KDMX,9,9),A3T2(KDMX,9,9), & A4T2(KDMX,9,9),A5T2(KDMX,9,9),A7T2(KDMX,9,9), & A1T4(KDMX,9,9),A2T4(KDMX,9,9),A3T4(KDMX,9,9), & A4T4(KDMX,9,9),A5T4(KDMX,9,9),A6T4(KDMX,9,9), & A1T5(KDMX,9,9),A2T5(KDMX,9,9),A3T5(KDMX,9,9), & A4T5(KDMX,9,9),A5T5(KDMX,9,9), & A4T5BB(KDMX,9,9),A5T5BB(KDMX,9,9), & A4T5B(KDMX,9,9),A5T5B(KDMX,9,9), & A7T5(KDMX,9,9),A8T5(KDMX,9,9),A9T5(KDMX,9,9), & A10T5(KDMX,9,9),A11T5(KDMX,9,9),A12T5(KDMX,9,9), & A13T5(KDMX,9,9),A14T5(KDMX,9,9),A15T5(KDMX,9,9), & A16T5(KDMX,9,9),A17T5(KDMX,9,9), & A1TS(KDMX,9,9),A2TS(KDMX,9,9),A5TS(KDMX,9,9), & A8T2(KDMX,9,9),A9T2(KDMX,9,9), & A20T4(KDMX,9,9),A21T4(KDMX,9,9) & ,A8T5B(KDMX,9,9),A9T5B(KDMX,9,9), & A14T5B(KDMX,9,9),A15T5B(KDMX,9,9) & ,A5T4B(KDMX,9,9),A6T4B(KDMX,9,9) & ,A10T2(KDMX,9,9),A11T2(KDMX,9,9),A1T4B(KDMX,9,9) & ,A10T5B(KDMX,9,9),A11T5B(KDMX,9,9) & ,A16T5B(KDMX,9,9),A17T5B(KDMX,9,9) & ,A6TS(KDMX,9,9),A18T5(KDMX,9,9),A19T5(KDMX,9,9) & ,A3T4B(KDMX,9,9),A4T4B(KDMX,9,9),A4T2B(KDMX,9,9) & ,A5T2B(KDMX,9,9) & ,A20T5(KDMX,9,9),A21T5(KDMX,9,9) COMMON /VRTD/ A1T1,A1T2,A2T2,A3T2,A4T2,A5T2,A7T2, & A1T4,A2T4,A3T4,A4T4,A5T4,A6T4, & A1T5,A2T5,A3T5,A4T5,A5T5,A7T5,A8T5,A9T5, & A10T5,A11T5,A12T5,A13T5,A14T5,A15T5,A16T5,A17T5, & A1TS,A2TS,A5TS,A8T2,A9T2,A20T4,A21T4 & ,A8T5B,A9T5B,A14T5B,A15T5B & ,A4T5B,A5T5B,A5T4B,A6T4B,A4T5BB,A5T5BB & ,A10T2,A11T2,A1T4B,A10T5B,A11T5B,A16T5B,A17T5B & ,A6TS,A18T5,A19T5,A3T4B,A4T4B,A4T2B,A5T2B & ,A20T5,A21T5 * REAL*8 EGT(KDMX,9,9) * F=CST(LO,101) * DO 1004 IVTORP = 1,9 DO 1002 IVTOR1 = 1,9 DO 1000 I = 1, 2 * N + 1 EGT(I,IVTOR1,IVTORP) = EGVC3(I,IVTORP) * EGVC3(I,IVTOR1) 1000 CONTINUE 1002 CONTINUE 1004 CONTINUE * IF (PARA (LO, L) .EQ. 'RHORHO') THEN VTORSA = 0.0 DO 7006 IVTORP = 1,9 DO 7004 IVTOR1 = 1,9 DO 7002 I = 1, 2 * N + 1 VTORSA = VTORSA + EGT(I,IVTOR1,IVTORP) & * (I - N - 1) * A1TS(I,IVTOR1,IVTORP) 7002 CONTINUE 7004 CONTINUE 7006 CONTINUE c VTORS = VTORSA * 2. * F cdebugik, 2Frho.pa.pg sign changed! VTORS = -VTORSA * 2. * F ELSE IF (PARA (LO, L) .EQ. 'F ') THEN VTORSB = 0.0 DO 7014 IVTORP = 1,9 DO 7012 IVTOR1 = 1,9 DO 7010 I = 1, 2 * N + 1 VTORSB = VTORSB + EGT(I,IVTOR1,IVTORP) & * A2TS(I,IVTOR1,IVTORP) 7010 CONTINUE 7012 CONTINUE 7014 CONTINUE VTORS = VTORSB ELSE IF (PARA (LO, L) .EQ. 'V3 ') THEN VTORSC = 0.0 DO 7022 IVTORP = 1,9 DO 7020 IVTOR1 = 1,9 DO 7018 I = 1, 2 * N + 1 VTORSC = VTORSC + EGT(I,IVTOR1,IVTORP) * & * (A1T1(I,IVTOR1,IVTORP) - A4TS(I,IVTOR1,IVTORP)) & * (A1T1(I,IVTOR1,IVTORP) - A1T5(I,IVTOR1,IVTORP)) 7018 CONTINUE 7020 CONTINUE 7022 CONTINUE VTORS = VTORSC / 2. ELSE IF (PARA (LO, L) .EQ. 'V6 ') THEN VTORSD = 0.0 DO 7030 IVTORP = 1,9 DO 7028 IVTOR1 = 1,9 DO 7026 I = 1, 2 * N + 1 VTORSD = VTORSD + EGT(I,IVTOR1,IVTORP) & * (A1T1(I,IVTOR1,IVTORP) - A12T5(I,IVTOR1,IVTORP)) 7026 CONTINUE 7028 CONTINUE 7030 CONTINUE VTORS = VTORSD / 2. ELSE IF (PARA (LO, L) .EQ. 'V9 ') THEN VTORSE = 0.0 DO 7038 IVTORP = 1,9 DO 7036 IVTOR1 = 1,9 DO 7034 I = 1, 2 * N + 1 VTORSE = VTORSE + EGT(I,IVTOR1,IVTORP) & * (A1T1(I,IVTOR1,IVTORP) - A5TS(I,IVTOR1,IVTORP)) 7034 CONTINUE 7036 CONTINUE 7038 CONTINUE VTORS = VTORSE / 2. ELSE IF (PARA (LO, L) .EQ. 'V12 ') THEN VTORSF = 0.0 DO 2038 IVTORP = 1,9 DO 2036 IVTOR1 = 1,9 DO 2034 I = 1, 2 * N + 1 VTORSF = VTORSF + EGT(I,IVTOR1,IVTORP) & * (A1T1(I,IVTOR1,IVTORP) - A6TS(I,IVTOR1,IVTORP)) 2034 CONTINUE 2036 CONTINUE 2038 CONTINUE VTORS = VTORSF / 2. END IF END C************************************************************* SUBROUTINE WIGNER(C,II,EGVL,KAFTER) c my insertion IMPLICIT REAL*8 ( A-H,O-Z ) C THIS PROGRAM READS AN EIGENVECTOR FROM BELGI28 AND MAKES A ROTATION OF C BETA RADIANS USING A WIGNER MATRIX. C IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1) COMMON/QUANT/ISIG,IV,N,KK COMMON/QUANT2/KKK(NDMX),NVT(NDMX),IPRITY(NDMX) DIMENSION C(KDMX),KBEF(NDMX),CP(KDMX),EGVL(NDMX),KOLD(NDMX) DIMENSION KAFTER(NDMX) C READ (5,*) KOLD, ENERGY C IF(N.EQ.8) THEN C WRITE (6,*) 'K BEFORE ROTATION=',KOLD(II),' ENERGY=',EGVL(II), C 1'II=',II C ENDIF IF(NVT(II).EQ.0) THEN BETA=-0.0792 ELSEIF(NVT(II).EQ.1.AND.ISIG.EQ.0) THEN IF(N.EQ.10) BETA=-0.0809 IF(N.EQ.11) BETA=-0.0811 IF(N.EQ.12) BETA=-0.0805 IF(N.EQ.13) BETA=-0.0794 C Change this angle back to 0.0785 and ask JTH! IF(N.EQ.14) BETA=-0.0350 IF(N.EQ.15) BETA=-0.0780 IF(N.EQ.16) BETA=-0.0780 IF(N.EQ.17) BETA=-0.0786 IF(N.EQ.18) BETA=-0.0794 IF(N.EQ.19) BETA=-0.0800 IF(N.EQ.20) BETA=-0.0803 IF(N.EQ.21) BETA=-0.0800 IF(N.EQ.22) BETA=-0.0794 IF(N.EQ.23) BETA=-0.0788 IF(N.EQ.24) BETA=-0.0785 IF(N.EQ.25) BETA=-0.0784 IF(N.EQ.26) BETA=-0.0787 IF(N.EQ.27) BETA=-0.0792 IF(N.EQ.28) BETA=-0.0797 IF(N.EQ.29) BETA=-0.0799 IF(N.EQ.30) BETA=-0.0798 C ISIG=1 ELSEIF(NVT(II).EQ.1.AND.ISIG.EQ.1) THEN IF(N.EQ.10) BETA=-0.0774 IF(N.EQ.11) BETA=-0.0783 C IF(N.EQ.12) BETA=-0.0796 IF(N.EQ.12) BETA=-0.0696 C IF(N.EQ.13) BETA=-0.0805 IF(N.EQ.13) BETA=-0.0505 C IF(N.EQ.14) BETA=-0.0807 IF(N.EQ.14) BETA=-0.0407 C IF(N.EQ.15) BETA=-0.0802 IF(N.EQ.15) BETA=-0.0302 C IF(N.EQ.16) BETA=-0.0794 IF(N.EQ.16) BETA=-0.0294 C IF(N.EQ.17) BETA=-0.0786 IF(N.EQ.17) BETA=-0.0286 C IF(N.EQ.18) BETA=-0.0782 IF(N.EQ.18) BETA=-0.0382 C IF(N.EQ.19) BETA=-0.0782 IF(N.EQ.19) BETA=-0.0382 C IF(N.EQ.20) BETA=-0.0786 IF(N.EQ.20) BETA=-0.0386 C IF(N.EQ.21) BETA=-0.0793 IF(N.EQ.21) BETA=-0.0293 C IF(N.EQ.22) BETA=-0.0799 IF(N.EQ.22) BETA=-0.0299 C IF(N.EQ.23) BETA=-0.0801 IF(N.EQ.23) BETA=-0.0301 C IF(N.EQ.24) BETA=-0.0799 IF(N.EQ.24) BETA=-0.0299 C IF(N.EQ.25) BETA=-0.0794 IF(N.EQ.25) BETA=-0.0294 C IF(N.EQ.26) BETA=-0.0789 IF(N.EQ.26) BETA=-0.0289 IF(N.EQ.27) BETA=-0.0785 C ISIG=-1,K NEGATIVES C ELSEIF(NVT(II).EQ.1.AND.ISIG.EQ.1) THEN C IF(N.EQ.10) BETA=-0.0795 C IF(N.EQ.11) BETA=-0.0783 C IF(N.EQ.12) BETA=-0.0777 C IF(N.EQ.13) BETA=-0.0777 C IF(N.EQ.14) BETA=-0.0785 C IF(N.EQ.15) BETA=-0.0795 C IF(N.EQ.16) BETA=-0.0802 C IF(N.EQ.17) BETA=-0.0804 C IF(N.EQ.18) BETA=-0.0801 C IF(N.EQ.19) BETA=-0.0794 C IF(N.EQ.20) BETA=-0.0788 C IF(N.EQ.21) BETA=-0.0783 C IF(N.EQ.22) BETA=-0.0783 C IF(N.EQ.23) BETA=-0.0787 C IF(N.EQ.24) BETA=-0.0793 C IF(N.EQ.25) BETA=-0.0798 C IF(N.EQ.26) BETA=-0.0800 C IF(N.EQ.27) BETA=-0.0798 ELSEIF(NVT(II).EQ.2.AND.ISIG.EQ.0) THEN IF(N.EQ.8) BETA=-0.0873 IF(N.EQ.9) BETA=-0.0759 IF(N.EQ.10) BETA=-0.0692 IF(N.EQ.11) BETA=-0.0662 IF(N.EQ.12) BETA=-0.0675 IF(N.EQ.13) BETA=-0.0762 IF(N.EQ.14) BETA=-0.0892 IF(N.EQ.15) BETA=-0.0935 IF(N.EQ.16) BETA=-0.0897 IF(N.EQ.17) BETA=-0.0837 IF(N.EQ.18) BETA=-0.0782 IF(N.EQ.19) BETA=-0.0740 IF(N.EQ.20) BETA=-0.0715 IF(N.EQ.21) BETA=-0.0717 IF(N.EQ.22) BETA=-0.0763 IF(N.EQ.23) BETA=-0.0842 IF(N.EQ.24) BETA=-0.0876 IF(N.EQ.25) BETA=-0.0861 IF(N.EQ.26) BETA=-0.0826 IF(N.EQ.27) BETA=-0.0790 IF(N.EQ.28) BETA=-0.0759 IF(N.EQ.29) BETA=-0.0739 IF(N.EQ.30) BETA=-0.0736 C ISIG=-1, K NEGATIVES, WE HAD TO TAKE 0.05 OFF ELSEIF(NVT(II).EQ.2.AND.ISIG.EQ.1.AND.KKK(II).LE.0) THEN IF(N.EQ.1) BETA=-0.0667 IF(N.EQ.2) BETA=-0.0667 C IF(N.EQ.2) BETA=-0.2842 C IF(N.EQ.3) BETA=-0.2543 IF(N.EQ.3) BETA=-0.0667 C IF(N.EQ.4) BETA=-0.1322 IF(N.EQ.4) BETA=-0.0500 IF(N.EQ.5) BETA=-0.0516 C IF(N.EQ.5) BETA=-0.0916 IF(N.EQ.6) BETA=-0.0339 C IF(N.EQ.6) BETA=-0.0739 IF(N.EQ.7) BETA=-0.0155 C IF(N.EQ.7) BETA=-0.0655 IF(N.EQ.8) BETA=-0.0024 C IF(N.EQ.8) BETA=-0.0624 IF(N.EQ.9) BETA=-0.0047 C IF(N.EQ.9) BETA=-0.0647 IF(N.EQ.10) BETA=-0.0161 C IF(N.EQ.10) BETA=-0.0761 IF(N.EQ.11) BETA=-0.0229 C IF(N.EQ.11) BETA=-0.0929 IF(N.EQ.12) BETA=-0.0177 C IF(N.EQ.12) BETA=-0.0977 IF(N.EQ.13) BETA=-0.0221 C IF(N.EQ.13) BETA=-0.0921 IF(N.EQ.14) BETA=-0.0244 C IF(N.EQ.14) BETA=-0.0844 IF(N.EQ.15) BETA=-0.0177 C IF(N.EQ.15) BETA=-0.0777 IF(N.EQ.16) BETA=-0.0129 C IF(N.EQ.16) BETA=-0.0729 IF(N.EQ.17) BETA=-0.0103 C IF(N.EQ.17) BETA=-0.0703 IF(N.EQ.18) BETA=-0.0107 C IF(N.EQ.18) BETA=-0.0707 IF(N.EQ.19) BETA=-0.0163 C IF(N.EQ.19) BETA=-0.0763 IF(N.EQ.20) BETA=-0.0254 C IF(N.EQ.20) BETA=-0.0854 IF(N.EQ.21) BETA=-0.0490 C IF(N.EQ.21) BETA=-0.0890 IF(N.EQ.22) BETA=-0.0469 C IF(N.EQ.22) BETA=-0.0869 IF(N.EQ.23) BETA=-0.0429 C IF(N.EQ.23) BETA=-0.0829 IF(N.EQ.24) BETA=-0.0388 C IF(N.EQ.24) BETA=-0.0788 IF(N.EQ.25) BETA=-0.0354 C IF(N.EQ.25) BETA=-0.0754 IF(N.EQ.26) BETA=-0.0333 C IF(N.EQ.26) BETA=-0.0733 IF(N.EQ.27) BETA=-0.0731 C ISIG=1, K POSITIVES ELSEIF(NVT(II).EQ.2.AND.ISIG.EQ.1.AND.KKK(II).GT.0) THEN IF(N.EQ.1) BETA=0.2257 IF(N.EQ.2) BETA=-0.1121 IF(N.EQ.3) BETA=-0.0692 IF(N.EQ.4) BETA=-0.0584 IF(N.EQ.5) BETA=-0.0558 IF(N.EQ.6) BETA=-0.0599 IF(N.EQ.7) BETA=-0.0759 C IF(N.EQ.8) BETA=-0.0999 IF(N.EQ.8) BETA=-0.0799 C IF(N.EQ.9) BETA=-0.1054 IF(N.EQ.9) BETA=-0.0854 C IF(N.EQ.10) BETA=-0.0962 IF(N.EQ.10) BETA=-0.0762 C IF(N.EQ.11) BETA=-0.0854 IF(N.EQ.11) BETA=-0.0654 C IF(N.EQ.12) BETA=-0.0770 IF(N.EQ.12) BETA=-0.0570 C IF(N.EQ.13) BETA=-0.0714 IF(N.EQ.13) BETA=-0.0514 C IF(N.EQ.14) BETA=-0.0686 IF(N.EQ.14) BETA=-0.0486 C IF(N.EQ.15) BETA=-0.0694 IF(N.EQ.15) BETA=-0.0494 C IF(N.EQ.16) BETA=-0.0762 IF(N.EQ.16) BETA=-0.0562 C IF(N.EQ.17) BETA=-0.0869 IF(N.EQ.17) BETA=-0.0469 C IF(N.EQ.18) BETA=-0.0908 IF(N.EQ.18) BETA=-0.0508 C IF(N.EQ.19) BETA=-0.0881 IF(N.EQ.19) BETA=-0.0481 C IF(N.EQ.20) BETA=-0.0833 IF(N.EQ.20) BETA=-0.0433 IF(N.EQ.21) BETA=-0.0785 IF(N.EQ.22) BETA=-0.0748 IF(N.EQ.23) BETA=-0.0725 IF(N.EQ.24) BETA=-0.0725 IF(N.EQ.25) BETA=-0.0763 IF(N.EQ.26) BETA=-0.0833 IF(N.EQ.27) BETA=-0.0866 IF(N.EQ.28) BETA=-0.0854 IF(N.EQ.29) BETA=-0.0824 IF(N.EQ.30) BETA=-0.0792 ELSEIF(NVT(II).EQ.3.AND.ISIG.EQ.0) THEN C IF(N.EQ.18) BETA=-0.1011 C IF(N.EQ.19) BETA=-0.1285 C IF(N.EQ.20) BETA=-0.1165 C IF(N.EQ.21) BETA=-0.1018 C IF(N.EQ.22) BETA=-0.0851 C IF(N.EQ.23) BETA=-0.0714 C IF(N.EQ.24) BETA=-0.0650 C IF(N.EQ.25) BETA=-0.0625 C IF(N.EQ.26) BETA=-0.0617 IF(N.GE.14) BETA=-0.0100 ELSEIF(NVT(II).EQ.3.AND.ISIG.EQ.1.AND.KKK(II).LE.0) THEN C IF(N.EQ.8) BETA=-0.2596 C IF(N.EQ.9) BETA=-0.1492 C IF(N.EQ.10) BETA=-0.0852 C IF(N.EQ.11) BETA=-0.0620 C IF(N.EQ.12) BETA=-0.0545 C IF(N.EQ.13) BETA=-0.0520 C IF(N.EQ.14) BETA=-0.0526 C IF(N.EQ.15) BETA=-0.1128 C IF(N.EQ.16) BETA=-0.1445 C IF(N.EQ.17) BETA=-0.1263 C IF(N.EQ.18) BETA=-0.1061 C IF(N.EQ.19) BETA=-0.0851 C IF(N.EQ.20) BETA=-0.0699 C IF(N.EQ.21) BETA=-0.0632 C IF(N.EQ.22) BETA=-0.0607 C IF(N.EQ.23) BETA=-0.0600 C IF(N.EQ.24) BETA=-0.0876 C IF(N.EQ.25) BETA=-0.1125 C IF(N.EQ.26) BETA=-0.1057 IF(N.GE.8) BETA=-0.0100 ELSEIF(NVT(II).EQ.3.AND.ISIG.EQ.1.AND.KKK(II).GT.0) THEN C IF(N.EQ.8) BETA=-0.0569 C IF(N.EQ.9) BETA=-0.0493 C IF(N.EQ.10) BETA=-0.0472 C IF(N.EQ.11) BETA=-0.0485 C IF(N.EQ.12) BETA=-0.1328 C IF(N.EQ.13) BETA=-0.1775 C IF(N.EQ.14) BETA=-0.1436 C IF(N.EQ.15) BETA=-0.1126 C IF(N.EQ.16) BETA=-0.0851 C IF(N.EQ.17) BETA=-0.0680 C IF(N.EQ.18) BETA=-0.0610 C IF(N.EQ.19) BETA=-0.0584 C IF(N.EQ.20) BETA=-0.0581 C IF(N.EQ.21) BETA=-0.0932 C IF(N.EQ.22) BETA=-0.1189 C IF(N.EQ.23) BETA=-0.1102 C IF(N.EQ.24) BETA=-0.0989 C IF(N.EQ.25) BETA=-0.0851 C IF(N.EQ.26) BETA=-0.0726 IF(N.GE.8) BETA=-0.0100 ENDIF C WRITE (6,*) 'THE ROTATION IS OF ', BETA,'RADIANS' C 1,'N=',N,'NVT=',NVT(II) DO 5 I=1,2*N+1 C READ (5,*) K(I),C(I) C BASIS FUNCTION KBEF : K BEFORE KBEF(I)=I-(N+1) 5 CONTINUE DO 25 I=1,2*N+1 SUM=0. DO 35 J=1,2*N+1 K1=KBEF(J) K2=KBEF(I) CALL ROTFCF (BETA,K1,K2,D) SUM=SUM+C(J)*D 35 CONTINUE CP(I)=SUM 25 CONTINUE C IF(N.EQ.8) THEN C WRITE (6,*) 'EIGENVECTOR BEFORE ROTATION' C DO 55 I=1,2*N+1 C WRITE (6,*) KBEF(I),C(I) C55 CONTINUE C WRITE (6,*) 'EIGENVECTOR AFTER ROTATION' C DO 45 I=1,2*N+1 C WRITE (6,*) KBEF(I),CP(I) C45 CONTINUE C ENDIF C SEARCHING THE BIGEST COEFFICIENT IN THE "PAM" EIGENVECTOR FOR C VT=0,1 ADAPTED FROM RESUM3 (FOR THE K LABELING) C XMAX=0. C DO 106 JJ=1,2*N+1 C IF (CP(JJ)*CP(JJ).GT.XMAX) THEN C XMAX=CP(JJ)*CP(JJ) C KAFTER(II)=IABS(JJ-(N+1)) C END IF C106 CONTINUE C A ROTATIONAL LABELING XMAX=0. KAFTER(II)=0 IF(ISIG.EQ.0) THEN DO 106 JJ=1,2*N+1 M=JJ-(N+1) MM=JJ-2*M IF (JJ.NE.MM) THEN IF ((CP(JJ)**2+CP(MM)**2).GT.XMAX) THEN XMAX=CP(JJ)**2+CP(MM)**2 KAFTER(II)=IABS(M) END IF ELSE IF (CP(JJ)**2.GT.XMAX) THEN XMAX=CP(JJ)**2 KAFTER(II)=0 END IF END IF 106 CONTINUE ELSE C ROTATIONAL LABELING. (E SPECIES) XMAX=0. KAFTER(II)=-N DO 107 JJ=1,2*N+1 C IF(N.EQ.9.OR.N.EQ.10.AND.NVT(II).EQ.2)THEN C PRINT*,'N=',N,'CP(JJ)=',CP(JJ),'JJ=',JJ C ENDIF IF (CP(JJ)*CP(JJ).GT.XMAX) THEN XMAX=CP(JJ)*CP(JJ) KAFTER(II)=JJ-(N+1) END IF C IF(N.EQ.9.OR.N.EQ.10.AND.NVT(II).EQ.2)THEN C PRINT*,'KAFTER=',KAFTER(II),'JJ=',JJ,'II=',II,'N=',N C ENDIF 107 CONTINUE ENDIF RETURN END SUBROUTINE ROTFCF (BETA,K1,K2,D) c my insertion IMPLICIT REAL*8 ( A-H,O-Z ) C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION TERM(100) COMMON/QUANT/ISIG,IV,N,KK C J=10 IF (N.LT.IABS(K1)) GO TO 40 IF (N.LT.IABS(K2)) GO TO 40 C DETNS LIMITS I1=0 IF ((K2-K1).GT.0) I1=K2-K1 I2=N-K1 IF ((N+K2).LT.I2) I2=N+K2 SUM=0. C=COS(0.5*BETA) S=-SIN(0.5*BETA) FAC= SQRT(FACT2(N+K2)*FACT2(N-K2) * *FACT2(N+K1)*FACT2(N-K1)) DO 50 I=I1,I2 IN1=2*N-K1+K2-2*I IN2=2*I+K1-K2 C TERM(I+1)=(-1)**I*SQRT(FACT2(N+K2)*FACT2(N-K2) C * *FACT2(N+K1)*FACT2(N-K1)) TERM(I+1)=(-1)**I*FAC * /(FACT2(N-K1-I)*FACT2(N+K2-I)*FACT2(I)*FACT2(I+K1-K2)) C * *C**(2*N-K1+K2-2*I)*S**(2*I+K1-K2) * *C**IN1*S**IN2 SUM=SUM+TERM(I+1) 50 CONTINUE COF=SUM GO TO 30 40 COF=0. 30 CONTINUE D=COF RETURN END FUNCTION FACT2(N) c my insertion IMPLICIT REAL*8 ( A-H,O-Z ) C IMPLICIT DOUBLE PRECISION (A-H,O-Z) PI=ACOS(-1.0) c my insertion an=N+1 FACT2=SQRT(2.0*PI/an)*EXP(1.0/(1.2*an))*((an/2.7182818284)**(N+1)) IF (N.LE.2) FACT2=1.+0.5*(N**2-N) c FACT2=SQRT(2.0*PI/(N+1.))*EXP(1.0/(1.2 c * *(N+1.)))*(((N+1.)/2.7182818284)**(N+1)) c IF (N.LE.2) FACT2=1.+0.5*(N**2-N) RETURN END C*********************************************************** INTEGER FUNCTION IPOSA2(EGVC,EGVL,A,EGVC4,PR) IMPLICIT REAL*8 ( A-H,O-Z ) C*********************************************************** C C CHANGES BY I.KLEINER AUGUST 4 1993 C C DETERMINES THE POSITION OF EIGENVECTORS AND VALUES ASSOCIATED C WITH THE K DATA AND FOR ISIG=0 , FOR KK>0, IV>0 C CHARACTER*1 PR PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1) COMMON/QUANT/ISIG,IV,N,KK COMMON/QUANT2/KKK(NDMX),NVT(NDMX),IPRITY(NDMX) COMMON/C2C/PERC2L,PER23L(NDMX) COMMON/EIGEN/H(NDMX,NDMX),WORK(NDMX),EGVC3(KDMX,9),NBR(2) DIMENSION EGVC(NDMX,NDMX),EGVL(NDMX) DIMENSION A(9,NTORMX,KDMX) DIMENSION EGVC4(KDMX,NTORMX,NDMX) C PARITY ASSIGNMENT IF (PR.EQ.'+') IPR=1 IF (PR.EQ.'-') IPR=2 DO 8 II=1,9*(2*N+1) C CALL PARITY(A,EGVC4,II) C PRINT*,'II APRES PARITY',II C NIV=N+NVT(II) C IF(MOD(NIV,2).EQ.0) THEN C IF(PER23L.GE.0.)THEN C IPRITY=1 C ELSE C IPRITY=2 C ENDIF C ELSE C IF(PER23L.GE.0.)THEN C IPRITY=2 C ELSE C IPRITY=1 C ENDIF C ENDIF C PRINT*,'IPRITY=',IPRITY(II),'IPR=',IPR,'N=',N,'KKK=',KKK(II) C 1 ,'NVT=',NVT(II),'IV=',IV,'KK=',KK,'IPR=',IPR IF (KK.EQ.KKK(II).AND.IV.EQ.NVT(II).AND.ISIG.EQ.0)THEN IF(IPR.EQ.IPRITY(II)) THEN IPOSA2=II IF(N.EQ.15) THEN c WRITE (6,1083) IV,KK,EGVL(II),N,PR,IPR,PER23L(II),II ENDIF END IF END IF 8 CONTINUE 1083 FORMAT (1X,'A ',' VT= ',I1,' K= ',I3,' ENER= ',F16.10,' CM-1', & ' N=',I3,' PAR=',A1,I1,1X,'(23)*=',F4.1,1X,I3) RETURN END C********************************************************** INTEGER FUNCTION IPOSA(EGVC,EGVL,A,EGVC4) IMPLICIT REAL*8 ( A-H,O-Z ) C*********************************************************** C C CHANGES BY J. ORTIGOSO JUNE 1, 1992 C C DETERMINES THE POSITION OF EIGENVECTORS AND VALUES ASSOCIATED C WITH THE K DATA AND FOR ISIG=0 C CHARACTER*1 PR,PROBS CHARACTER*6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1) COMMON/QUANT/ISIG,IV,N,KK COMMON/CHARA/PARA(2,160),PR,PROBS(2,80000),REF(80000) COMMON/ROTOR/NROTOR,NDIMTO COMMON/QUANT2/KKK(NDMX),NVT(NDMX),IPRITY(NDMX) COMMON/C2C/PERC2L,PER23L(NDMX) COMMON/EIGEN/H(NDMX,NDMX),WORK(NDMX),EGVC3(KDMX,9),NBR(2) DIMENSION EGVC(NDMX,NDMX),SUM(9), & EGVL(NDMX),KKC(0:NDMX),KKKU(0:NDMX),KKCU(0:NDMX), & KKKD(0:NDMX),KKCD(0:NDMX),NAUX(0:NDMX),NCHAR(0:NDMX) DIMENSION A(9,NTORMX,KDMX) DIMENSION EGVC4(KDMX,NTORMX,NDMX),EGVCV3(KDMX),KAFTER(NDMX) C PARITY ASSIGNMENT IF (PR.EQ.'+') IPR=1 IF (PR.EQ.'-') IPR=2 C TORSIONAL LABELING DO 1 I=1,9 SUM(I)=0. 1 CONTINUE DO 2 I=1,NDMX NVT(I)=0 KKK(I)=0 KKC(I)=0 KKKU(I)=0 KKKD(I)=0 KKCU(I)=0 KKCD(I)=0 NAUX(I)=0 NCHAR(I)=0 2 CONTINUE DO 3 II=1,9*(2*N+1) IKT=0 DO 4 KT=1,9*(2*N+1),2*N+1 IF (KT.GT.9*(2*N+1)) GO TO 4 IKT=IKT+1 SUM(IKT)=0. DO 5 I=KT,2*N+KT C PRINT *, 'EGVC',EGVC(I,II) SUM(IKT)=EGVC(I,II)*EGVC(I,II)+SUM(IKT) 5 CONTINUE IF (IKT.EQ.1) XMAX=SUM(IKT) IF (IKT.NE.1) THEN IF (SUM(IKT).GT.XMAX) THEN XMAX=SUM(IKT) NVT(II)=IKT-1 END IF END IF 4 CONTINUE 3 CONTINUE C ROTATIONAL LABELING DO 6 JJ=1,9 I=-1 DO 7 II=1,9*(2*N+1) IF (NVT(II)+1.NE.JJ) GO TO 7 I=I+1 IF (I.EQ.0) THEN KKK(II)=0 KKC(II)=N ELSE IF (I.NE.I/2*2) THEN KKK(II)=I-((I-1)/2) KKC(II)=N-KKK(II)+1 ELSE IF (I.NE.0.AND.I.EQ.I/2*2) THEN KKK(II)=I-I/2 KKC(II)=N-KKK(II) END IF 7 CONTINUE 6 CONTINUE III=0 JJJ=(2*N+1)*9+1 DO 17 II=1,9*(2*N+1) C IS THE FOLLOWING CARD RIGHT? C IF (NVT(II)+1.NE.3) GO TO 17 IF (NVT(II).NE.3) GO TO 17 C IF VT=3 WE CALCULATE THE KA CHARACTER OF THE EIGENFUNCTION XMAX=0. III=III+1 JJJ=JJJ-1 NCHAR(III)=N DO 27 LL=(2*N+1)*NVT(II)+1,(2*N+1)*NVT(II)+(2*N+1) IF (EGVC(LL,II)*EGVC(LL,II).GT.XMAX) THEN XMAX=EGVC(LL,II)*EGVC(LL,II) NCHAR(III)=ABS(LL-(N+1)-NVT(II)*(2*N+1)) END IF 27 CONTINUE KKKU(III)=KKK(II) KKCU(III)=KKC(II) KKKD(JJJ)=KKK(II) KKCD(JJJ)=KKC(II) NAUX(III)=II 17 CONTINUE III=1 JJJ=1 II=2*N+2 DO 18 JJ=1,(2*N+1) II=II-1 DIF1=ABS(KKKU(III)-NCHAR(II)) DIF2=ABS(KKKD(JJJ)-NCHAR(II)) IF (DIF1.GE.DIF2) THEN KKK(NAUX(II))=KKKD(JJJ) KKC(NAUX(II))=KKCD(JJJ) JJJ=JJJ+1 ELSE KKK(NAUX(II))=KKKU(III) KKC(NAUX(II))=KKCU(III) III=III+1 END IF 18 CONTINUE C SEARCHING FOR EIGENVALUES AND EIGENVECTORS, FOR VT=3 DO 66 JJ=1,9*(2*N+1) IF(NVT(JJ).EQ.3.AND.N.LT.14.OR.NVT(JJ).GE.4) THEN XMAX=0. KKK(JJ)=N DO 77 II=(2*N+1)*NVT(JJ)+1,(2*N+1)*NVT(JJ)+(N+1) M=II-(N+1)-NVT(JJ)*(2*N+1) MM=II-2*M IF (II.NE.MM) THEN IF ((EGVC(II,JJ)**2+EGVC(MM,JJ)**2).GT.XMAX) THEN XMAX=EGVC(II,JJ)**2+EGVC(MM,JJ)**2 KKK(JJ)=IABS(M) END IF ELSE IF (EGVC(II,JJ)**2.GT.XMAX) THEN XMAX=EGVC(II,JJ)**2 KKK(JJ)=0 END IF END IF 77 CONTINUE ENDIF 66 CONTINUE DO 8 II=1,9*(2*N+1) IF(NVT(II).EQ.3.AND.N.GE.14) THEN DO 64 I=3*(2*N+1)+1,4*(2*N+1) IK=I-NVT(II)*(2*N+1) EGVCV3(IK)=EGVC(I,II) 64 CONTINUE CALL WIGNER(EGVCV3,II,EGVL,KAFTER) KKK(II)=KAFTER(II) ENDIF C PRINT*,'II=AVANT PARITY',II C IF (N/2*2.EQ.N) THEN C IF (KKC(II)/2*2.EQ.KKC(II)) THEN C IPRITY=1 C ELSE C IPRITY=0 C END IF C ELSE C IF (KKC(II)/2*2.NE.KKC(II)) THEN C IPRITY=1 C ELSE C IPRITY=0 C END IF C END IF CALL PARITY(A,EGVC4,II) C PRINT*,'II APRES PARITY',II NIV=N+NVT(II) IF(MOD(NIV,2).EQ.0) THEN IF(PER23L(II).GE.0.)THEN IPRITY(II)=1 ELSE IPRITY(II)=2 ENDIF ELSE IF(PER23L(II).GE.0.)THEN IPRITY(II)=2 ELSE IPRITY(II)=1 ENDIF ENDIF C PRINT*,'IPR=',IPR,'IPRITY=',IPRITY,'EGVL',EGVL(II),'II=',II IF (KK.EQ.KKK(II).AND.IV.EQ.NVT(II).AND.ISIG.EQ.0)THEN IF(IPR.EQ.IPRITY(II)) THEN IPOSA=II IF(N.EQ.15) THEN c WRITE (6,1083) IV,KK,EGVL(II),N,PR,IPR,PER23L(II),II ENDIF END IF END IF 8 CONTINUE 1083 FORMAT (1X,'A ',' VT= ',I1,' K= ',I3,' ENER= ',F16.10,' CM-1', & ' N=',I3,' PAR=',A1,I1,1X,'(23)*=',F4.1,1X,I3) RETURN END C************************************************************* C************************************************************* INTEGER FUNCTION IPOSE(EGVC,EGVL) IMPLICIT REAL*8 ( A-H,O-Z ) C*********************************************************** CHARACTER*1 PR,PROBS CHARACTER*6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1) COMMON/QUANT/ISIG,IV,N,KK COMMON/QUANT2/KKK(NDMX),NVT(NDMX),IPRITY(NDMX) COMMON/CHARA/PARA(2,160),PR,PROBS(2,80000),REF(80000) COMMON/ROTOR/NROTOR,NDIMTO COMMON/C2C/PERC2L,PER23L(NDMX) DIMENSION EGVC(NDMX,NDMX),EGVL(NDMX) & ,SUM(NDMX,9) DIMENSION EGVCV3(KDMX),KAFTER(NDMX) C C DETERMINES THE POSITION OF EIGENVAL. ASSOCIATED WITH K DATA C AND FOR THE STATE LO IN THE CASE ISIG=1 C C*********************************************************** C IF (N.EQ.NANT.AND.N.NE.0) GO TO 30 C NANT=N C TORSIONAL LABELING DO 1 I=1,NDMX DO 1 J=1,9 SUM(I,J)=0. 1 CONTINUE DO 2 I=1,NDMX NVT(I)=0 KKK(I)=0 2 CONTINUE DO 3 II=1,9*(2*N+1) IKT=0 DO 4 KT=1,9*(2*N+1),2*N+1 IF (KT.GT.9*(2*N+1)) GO TO 4 IKT=IKT+1 DO 5 I=KT,2*N+KT C PRINT *, 'EGVC',EGVC(I,II) SUM(II,IKT)=EGVC(I,II)*EGVC(I,II)+SUM(II,IKT) 5 CONTINUE 4 CONTINUE C PRINT *, NVT(II) 3 CONTINUE DO 23 J=1,9 DO 22 JJ=1,2*N+1 XMAX=0. DO 21 I=1,9*(2*N+1) IF (SUM(I,J).GT.XMAX) THEN XMAX=SUM(I,J) NIN=I END IF 21 CONTINUE NVT(NIN)=J-1 DO 24 II=1,9 SUM(NIN,II)=0. 24 CONTINUE 22 CONTINUE 23 CONTINUE C ROTATIONAL LABELING. THE SAME SCHEME THAN ISABELLE'S IN RESUM2. C DO 6 JJ=1,9*(2*N+1) C XMAX=0. C KKK(JJ)=-N C DO 7 II=(2*N+1)*NVT(JJ)+1,(2*N+1)*NVT(JJ)+(2*N+1) C IF (EGVC(II,JJ)*EGVC(II,JJ).GT.XMAX) THEN C XMAX=EGVC(II,JJ)*EGVC(II,JJ) C KKK(JJ)=II-(N+1)-NVT(JJ)*(2*N+1) C END IF C7 CONTINUE C6 CONTINUE CC C CHECKING IF THERE ARE TWO EIGENVALUES WITH THE SAME LABELS CC C40 ISTR=0 C DO 42 J = 1,9*(2*N+1)-1 C DO 43 I = J+1,9*(2*N+1) C IF (NVT(I).NE.NVT(J).OR.KKK(I).NE.KKK(J)) GO TO 43 C ISTR=ISTR+1 C PROD1=EGVC(KKK(J)+(N+1)+NVT(J)*(2*N+1),J)**2 C PROD2=EGVC(KKK(I)+(N+1)+NVT(I)*(2*N+1),I)**2 C IF (PROD1.GT.PROD2) THEN C PROD11=EGVC(KKK(I)+(N+1)+NVT(I)*(2*N+1)+1,I)**2 C PROD22=EGVC(KKK(I)+(N+1)+NVT(I)*(2*N+1)-1,I)**2 C IF (PROD11.GT.PROD22) THEN C KKK(I)=KKK(I)+1 CC ELSE C KKK(I)=KKK(I)-1 C END IF C ELSE C PROD11=EGVC(KKK(J)+(N+1)+NVT(J)*(2*N+1)+1,J)**2 C PROD22=EGVC(KKK(J)+(N+1)+NVT(J)*(2*N+1)-1,J)**2 C IF (PROD11.GT.PROD22) THEN C KKK(J)=KKK(J)+1 C ELSE C KKK(J)=KKK(J)-1 C END IF C END IF C43 CONTINUE C42 CONTINUE C IF (ISTR.NE.0) GO TO 40 DO 40 JJ=1,9 III=0 DO 41 II=1,9*(2*N+1) IF (NVT(II)+1.EQ.JJ) THEN III=III+1 IF (NVT(II).EQ.0) THEN IF (III.EQ.1) THEN KKK(II)=0 NAN=II cc here we modify the labelling energy ordering for acetic acid cc K=1 to 18, the -K lebels are below the +K levels. c ELSE IF ((III.LT.10.AND.III.NE.1).OR.(III.GT.20.AND. c & III.LT.30)) THEN ELSE IF(III.LT.38.AND.III.NE.1) THEN IF (III.EQ.III/2*2) THEN KKK(II)=KKK(NAN)-III+1 NAN=II ELSE IF (III.NE.III/2*2) THEN KKK(II)=III-1+KKK(NAN) NAN=II END IF c ELSE IF (III.EQ.10.OR.III.EQ.30) THEN ELSEIF(III.EQ.38) THEN KKK(II)=III-1-KKK(NAN) NAN=II c ELSE IF ((III.GT.10.AND.III.LT.20).OR. c & (III.GT.30.AND.III.LT.40)) THEN ELSEIF(III.GT.38) THEN IF (III.NE.III/2*2) THEN KKK(II)=KKK(NAN)-III+1 NAN=II ELSE IF (III.EQ.III/2*2) THEN KKK(II)=III-1+KKK(NAN) NAN=II END IF c ELSE IF (III.EQ.20.OR.III.EQ.40) THEN c KKK(II)=-(III-1+KKK(NAN)) c NAN=II c ELSE IF (III.GT.40) THEN c IF (III.NE.III/2*2) THEN c KKK(II)=III-1+KKK(NAN) c NAN=II c ELSE IF (III.EQ.III/2*2) THEN c KKK(II)=KKK(NAN)-III+1 c NAN=II c END IF END IF ELSE IF (NVT(II).EQ.1) THEN IF (III.EQ.1) THEN KKK(II)=0 NAN=II c ELSE IF ((III.LT.10.AND.III.NE.1).OR.(III.GT.20.AND. c & III.LT.30)) THEN ELSEIF(III.LT.38.AND.III.NE.1) THEN IF (III.NE.III/2*2) THEN KKK(II)=KKK(NAN)-III+1 NAN=II ELSE IF (III.EQ.III/2*2) THEN KKK(II)=III-1+KKK(NAN) NAN=II END IF c ELSE IF (III.EQ.10.OR.III.EQ.30) THEN elseif(III.EQ.38) then KKK(II)=-(III-1+KKK(NAN)) NAN=II c ELSE IF ((III.GT.10.AND.III.LT.20).OR. c & (III.GT.30.AND.III.LT.40)) THEN elseif(III.GT.38) then IF (III.EQ.III/2*2) THEN KKK(II)=KKK(NAN)-III+1 NAN=II ELSE IF (III.NE.III/2*2) THEN KKK(II)=III-1+KKK(NAN) NAN=II END IF c ELSE IF (III.EQ.20.OR.III.EQ.40) THEN c KKK(II)=III-1-KKK(NAN) c NAN=II c ELSE IF (III.GT.40) THEN c IF (III.EQ.III/2*2) THEN c KKK(II)=III-1+KKK(NAN) c NAN=II c ELSE IF (III.NE.III/2*2) THEN c KKK(II)=KKK(NAN)-III+1 c NAN=II c END IF END IF ELSE IF (NVT(II).GE.2) THEN IF (III.EQ.1) THEN IF (N.EQ.0) THEN KKK(II)=0 ELSE IF (N.EQ.1) THEN KKK(II)=-1 ELSE KKK(II)=-2 END IF ELSE IF (III.EQ.2) THEN IF (N.EQ.1) THEN KKK(II)=0 ELSE KKK(II)=-1 END IF ELSE IF (III.EQ.3) THEN IF (N.EQ.1) THEN KKK(II)=1 ELSE IF (N.EQ.2) THEN KKK(II)=0 ELSE KKK(II)=-3 END IF ELSE IF (III.EQ.4) THEN IF (N.EQ.2) THEN KKK(II)=1 ELSE KKK(II)=0 END IF ELSE IF (III.EQ.5) THEN IF (N.EQ.2) THEN KKK(II)=2 ELSE KKK(II)=1 END IF ELSE IF (III.EQ.6) THEN KKK(II)=2 ELSE IF (III.EQ.7) THEN IF (N.EQ.3.OR.N.GE.13) THEN KKK(II)=3 ELSE KKK(II)=-4 END IF ELSE IF (III.EQ.8) THEN IF (N.LT.13) THEN KKK(II)=3 ELSE KKK(II)=-4 END IF ELSE IF (III.EQ.9) THEN KKK(II)=4 NAN=II ELSE IF (III.GT.20.AND.III.LT.30) THEN IF (III.EQ.III/2*2) THEN KKK(II)=KKK(NAN)-III+1 NAN=II ELSE IF (III.NE.III/2*2) THEN KKK(II)=III-1+KKK(NAN) NAN=II END IF ELSE IF (III.EQ.10.OR.III.EQ.30) THEN KKK(II)=III-1-KKK(NAN) NAN=II ELSE IF ((III.GT.10.AND.III.LT.20).OR. & (III.GT.30.AND.III.LT.40)) THEN IF (III.NE.III/2*2) THEN KKK(II)=KKK(NAN)-III+1 NAN=II ELSE IF (III.EQ.III/2*2) THEN KKK(II)=III-1+KKK(NAN) NAN=II END IF ELSE IF (III.EQ.20.OR.III.EQ.40) THEN KKK(II)=-(III-1+KKK(NAN)) NAN=II ELSE IF (III.GT.40) THEN IF (III.NE.III/2*2) THEN KKK(II)=III-1+KKK(NAN) NAN=II ELSE IF (III.EQ.III/2*2) THEN KKK(II)=KKK(NAN)-III+1 NAN=II END IF END IF END IF END IF 41 CONTINUE 40 CONTINUE DO 8 II=1,9*(2*N+1) IF (NVT(II).EQ.2) THEN IF (N.GE.19.AND.ABS(KKK(II)).EQ.9) THEN KKK(II)=-KKK(II) END IF END IF C ROTATIONAL LABELING FOR VT=3 c IF(NVT(II).EQ.3.AND.N.LT.8.OR.NVT(II).GE.4) THEN cjth Here I changed the labelling (just like I did for p-tolual) so that cjth we are now using the biggest coefficient to label E species for acetamide. cjth I have changed back to nvt(ii).eq.3, because it the coeff scheme doesn't cjth work for acetamide. c if(nvt(ii).eq.0) then if(nvt(ii).eq.3) then XMAX=0. KKK(II)=-N DO 7 JJ=(2*N+1)*NVT(II)+1,(2*N+1)*NVT(II)+(2*N+1) IF (EGVC(JJ,II)*EGVC(JJ,II).GT.XMAX) THEN XMAX=EGVC(JJ,II)*EGVC(JJ,II) KKK(II)=JJ-(N+1)-NVT(II)*(2*N+1) END IF 7 CONTINUE CC cc changes by ik, nov 13 2000 elseif(nvt(ii).eq.0) then c for high barrier molecules go to 664 go to 664 if(N.EQ.0) then KKK(II)=0 elseif(N.EQ.1) then if(II.EQ.1) KKK(II)=1 if(II.EQ.2) KKK(II)=0 if(II.EQ.3) KKK(II)=-1 elseif(N.GE.2) then if(II.EQ.1) KKK(II)=2 if(II.EQ.2) KKK(II)=1 if(II.EQ.3.AND.N.EQ.2) KKK(II)=0 if(II.EQ.4.AND.N.EQ.2) KKK(II)=-1 if(II.EQ.5.AND.N.EQ.2) KKK(II)=-2 endif if(N.GE.3) then if(II.EQ.3) KKK(II)=3 if(II.EQ.4) KKK(II)=0 if(II.EQ.5.AND.N.EQ.3) KKK(II)=-1 if(II.EQ.6.AND.N.EQ.3) KKK(II)=-2 if(II.EQ.7.AND.N.EQ.3) KKK(II)=-3 if(N.EQ.3) then endif endif if(N.GE.4) then if(II.EQ.5) KKK(II)=4 if(II.EQ.6) KKK(II)=-1 if(II.EQ.7.AND.N.EQ.4) KKK(II)=-2 if(II.EQ.8.AND.N.EQ.4) KKK(II)=-3 if(II.EQ.9.AND.N.EQ.4) KKK(II)=-4 endif if(N.GE.5) then if(II.EQ.7) KKK(II)=5 if(II.EQ.8) KKK(II)=-2 if(II.EQ.9.AND.N.EQ.5) KKK(II)=-3 if(II.EQ.10.AND.N.EQ.5) KKK(II)=-4 if(II.EQ.11.AND.N.EQ.5) KKK(II)=-5 endif if(N.GE.6) then if(II.EQ.9) KKK(II)=6 if(II.EQ.10) KKK(II)=-3 if(II.EQ.11.AND.N.EQ.6) KKK(II)=-4 if(II.EQ.12.AND.N.EQ.6) KKK(II)=-5 if(II.EQ.13.AND.N.EQ.6) KKK(II)=-6 endif if(N.GE.7) then if(II.EQ.11) KKK(II)=7 if(II.EQ.12) KKK(II)=-4 if(II.EQ.13.AND.N.EQ.7) KKK(II)=-5 if(II.EQ.14.AND.N.EQ.7) KKK(II)=-6 if(II.EQ.15.AND.N.EQ.7) KKK(II)=-7 endif if(N.GE.8) then if(II.EQ.13) KKK(II)=8 if(II.EQ.14) KKK(II)=-5 if(II.EQ.15.AND.N.EQ.8) KKK(II)=-6 if(II.EQ.16.AND.N.EQ.8) KKK(II)=-7 if(II.EQ.17.AND.N.EQ.8) KKK(II)=-8 endif if(N.GE.9) then if(II.EQ.15) KKK(II)=9 if(II.EQ.16) KKK(II)=-6 if(II.EQ.17.AND.N.EQ.9) KKK(II)=-7 if(II.EQ.18.AND.N.EQ.9) KKK(II)=-8 if(II.EQ.19.AND.N.EQ.9) KKK(II)=-9 endif if(N.EQ.10) then if(II.EQ.17) KKK(II)=-7 if(II.EQ.18) KKK(II)=10 if(II.EQ.19.AND.N.EQ.10) KKK(II)=-8 if(II.EQ.22.AND.N.EQ.10) KKK(II)=-9 if(II.EQ.23.AND.N.EQ.10) KKK(II)=-10 endif 664 IIJ=1 ELSEIF(NVT(II).EQ.3.AND.N.GE.8) THEN DO 64 I=3*(2*N+1)+1,4*(2*N+1) IK=I-NVT(II)*(2*N+1) EGVCV3(IK)=EGVC(I,II) 64 CONTINUE CALL WIGNER(EGVCV3,II,EGVL,KAFTER) KKK(II)=KAFTER(II) ENDIF c Go immediately to the end! go to 16 IF(N.EQ.10.AND.II.EQ.73) THEN KKK(II)=-4 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.11.AND.II.EQ.77) THEN KKK(II)=-4 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.12.AND.II.EQ.81) THEN KKK(II)=-4 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.13.AND.II.EQ.85) THEN KKK(II)=-4 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.14.AND.II.EQ.87) THEN KKK(II)=-4 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.15.AND.II.EQ.89) THEN KKK(II)=-4 NVT(II)=3 GO TO 16 ENDIF IF(N.GE.16.AND.II.EQ.91) THEN KKK(II)=-4 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.9.AND.II.EQ.74) THEN KKK(II)=6 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.10.AND.II.EQ.80) THEN KKK(II)=6 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.11.AND.II.EQ.85) THEN KKK(II)=6 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.12.AND.II.EQ.89) THEN KKK(II)=6 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.13.AND.II.EQ.92) THEN KKK(II)=6 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.14.AND.II.EQ.96) THEN KKK(II)=6 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.15.AND.II.EQ.98) THEN KKK(II)=6 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.16.AND.II.EQ.100) THEN KKK(II)=6 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.17.AND.II.EQ.100) THEN KKK(II)=6 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.18.AND.II.EQ.100) THEN KKK(II)=6 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.19.AND.II.EQ.98) THEN KKK(II)=6 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.20.AND.II.EQ.97) THEN KKK(II)=6 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.21.AND.II.EQ.97) THEN KKK(II)=6 NVT(II)=3 GO TO 16 ENDIF IF(N.GE.22.AND.II.EQ.96) THEN KKK(II)=6 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.8.AND.II.EQ.69) THEN KKK(II)=7 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.9.AND.II.EQ.75) THEN KKK(II)=7 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.10.AND.II.EQ.81) THEN KKK(II)=7 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.11.AND.II.EQ.87) THEN KKK(II)=7 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.12.AND.II.EQ.91) THEN KKK(II)=7 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.13.AND.II.EQ.94) THEN KKK(II)=7 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.14.AND.II.EQ.98) THEN KKK(II)=7 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.15.AND.II.EQ.100) THEN KKK(II)=7 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.16.AND.II.EQ.102) THEN KKK(II)=7 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.17.AND.II.EQ.104) THEN KKK(II)=7 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.18.AND.II.EQ.104) THEN KKK(II)=7 NVT(II)=3 GO TO 16 ENDIF IF(N.GE.19.AND.II.EQ.103) THEN KKK(II)=7 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.8.AND.II.EQ.61) THEN KKK(II)=-7 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.9.AND.II.EQ.67) THEN KKK(II)=-7 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.10.AND.II.EQ.71) THEN KKK(II)=-7 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.11.AND.II.EQ.75) THEN NVT(II)=3 KKK(II)=-7 GO TO 16 ENDIF IF(N.EQ.12.AND.II.EQ.79) THEN KKK(II)=-7 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.13.AND.II.EQ.83) THEN KKK(II)=-7 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.14.AND.II.EQ.85) THEN KKK(II)=-7 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.15.AND.II.EQ.87) THEN KKK(II)=-7 NVT(II)=3 GO TO 16 ENDIF IF(N.GE.16.AND.II.EQ.89) THEN KKK(II)=-7 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.9.AND.II.EQ.77) THEN KKK(II)=8 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.10.AND.II.EQ.83) THEN KKK(II)=8 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.11.AND.II.EQ.89) THEN KKK(II)=8 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.12.AND.II.EQ.93) THEN KKK(II)=8 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.13.AND.II.EQ.97) THEN KKK(II)=8 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.14.AND.II.EQ.100)THEN KKK(II)=8 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.15.AND.II.EQ.102)THEN KKK(II)=8 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.16.AND.II.EQ.104)THEN KKK(II)=8 NVT(II)=3 GO TO 16 ENDIF IF(N.GE.17.AND.II.EQ.106)THEN KKK(II)=8 NVT(II)=3 GO TO 16 ENDIF IF(N.GE.17.AND.II.EQ.95) THEN KKK(II)=-8 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.10.AND.II.EQ.85) THEN KKK(II)=9 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.11.AND.II.EQ.91) THEN NVT(II)=3 KKK(II)=9 GO TO 16 ENDIF IF(N.EQ.12.AND.II.EQ.95) THEN KKK(II)=9 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.13.AND.II.EQ.99) THEN KKK(II)=9 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.14.AND.II.EQ.103)THEN KKK(II)=9 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.15.AND.II.EQ.105)THEN KKK(II)=9 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.16.AND.II.EQ.107)THEN KKK(II)=9 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.17.AND.II.EQ.109)THEN KKK(II)=9 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.18.AND.II.EQ.109)THEN KKK(II)=9 NVT(II)=3 GO TO 16 ENDIF IF(N.EQ.19.AND.II.EQ.109)THEN KKK(II)=9 NVT(II)=3 GO TO 16 ENDIF IF(N.GE.20.AND.II.EQ.108)THEN KKK(II)=9 NVT(II)=3 GO TO 16 ENDIF IF(N.GE.16.AND.II.EQ.96) THEN KKK(II)=-3 NVT(II)=4 GO TO 16 ENDIF IF(N.EQ.16.AND.II.EQ.112)THEN KKK(II)=5 NVT(II)=4 GO TO 16 ENDIF IF(N.EQ.17.AND.II.EQ.115)THEN KKK(II)=5 NVT(II)=4 GO TO 16 ENDIF IF(N.GE.18.AND.II.EQ.116)THEN KKK(II)=5 NVT(II)=4 GO TO 16 ENDIF IF(N.EQ.10.AND.II.EQ.87) THEN KKK(II)=6 NVT(II)=4 GO TO 16 ENDIF IF(N.EQ.11.AND.II.EQ.93) THEN KKK(II)=6 NVT(II)=4 GO TO 16 ENDIF IF(N.EQ.12.AND.II.EQ.98) THEN KKK(II)=6 NVT(II)=4 GO TO 16 ENDIF IF(N.EQ.13.AND.II.EQ.102)THEN KKK(II)=6 NVT(II)=4 GO TO 16 ENDIF IF(N.EQ.14.AND.II.EQ.106)THEN KKK(II)=6 NVT(II)=4 GO TO 16 ENDIF IF(N.EQ.15.AND.II.EQ.108)THEN KKK(II)=6 NVT(II)=4 GO TO 16 ENDIF IF(N.EQ.16.AND.II.EQ.110)THEN KKK(II)=6 NVT(II)=4 GO TO 16 ENDIF IF(N.EQ.17.AND.II.EQ.112)THEN KKK(II)=6 NVT(II)=4 GO TO 16 ENDIF IF(N.EQ.18.AND.II.EQ.112)THEN KKK(II)=6 NVT(II)=4 GO TO 16 ENDIF IF(N.EQ.19.AND.II.EQ.112)THEN KKK(II)=6 NVT(II)=4 GO TO 16 ENDIF IF(N.EQ.20.AND.II.EQ.112) THEN KKK(II)=6 NVT(II)=4 GO TO 16 ENDIF IF(N.EQ.21.AND.II.EQ.111)THEN KKK(II)=6 NVT(II)=4 GO TO 16 ENDIF IF(N.EQ.22.AND.II.EQ.110)THEN KKK(II)=6 NVT(II)=4 GO TO 16 ENDIF ccikdebug sign c16 KKK(II)=-KKK(II) 16 IF (KK.EQ.KKK(II).AND.IV.EQ.NVT(II)) THEN IPOSE=II c IF(N.EQ.15) THEN c WRITE (6,1084) IV,KK,EGVL(II),N,II c ENDIF END IF 8 CONTINUE 1084 FORMAT (1X,'E ',' VT= ',I4,' K= ',I4,' ENER= ',F18.10,' CM-1', & ' N=',I3,1X,I4) RETURN END C************************************************************* INTEGER FUNCTION IPOSE2(EGVC,EGVL) IMPLICIT REAL*8 ( A-H,O-Z ) C*********************************************************** C C CHANGES BY I.KLEINER AUGUST 4 1993 C C DETERMINES THE POSITION OF EIGENVECTORS AND VALUES ASSOCIATED C WITH THE K DATA AND FOR ISIG=0 , FOR KK>0, IV>0 C CHARACTER*1 PR PARAMETER(NDMX=(2*(30)+1)*(9),KDMX=2*(30)+1,NTORMX=2*(10)+1) COMMON/QUANT/ISIG,IV,N,KK COMMON/QUANT2/KKK(NDMX),NVT(NDMX),IPRITY(NDMX) COMMON/EIGEN/H(NDMX,NDMX),WORK(NDMX),EGVC3(KDMX,9),NBR(2) DIMENSION EGVC(NDMX,NDMX),EGVL(NDMX) DO 8 II=1,(9)*(2*N+1) IF (KK.EQ.KKK(II).AND.IV.EQ.NVT(II).AND.ISIG.EQ.1)THEN IPOSE2=II c IF(N.EQ.15) THEN c WRITE (6,1084) IV,KK,EGVL(II),N,II c ENDIF 1084 FORMAT (1X,'E ',' VT= ',I4,' K= ',I4,' ENER2= ',F18.10,' CM-1', & ' N=',I3,1X,I4) END IF 8 CONTINUE RETURN END SUBROUTINE TQL2(NM,NN,D,E,Z,IERR) IMPLICIT REAL*8 ( A-H,O-Z ) C INTEGER I,J,K,L,M,N,II,L1,NM,MML,IERR,NN REAL*8D(NN),E(NN),Z(NN,NN) REAL*8 B,C,F,G,H,P,R,S,MACHEP C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQL2, C NUM. MATH. 11, 293-306(1968) BY BOWDLER, MARTIN, REINSCH, AND C WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971). C C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS C OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE QL METHOD. C THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO C BE FOUND IF TRED2 HAS BEEN USED TO REDUCE THIS C FULL MATRIX TO TRIDIAGONAL FORM. C C ON INPUT:D C C NM IS DIMENSION OF MATRIX ACTUALLY TRANSFORMED. C C NN IS THE DIMENSION OF THE WHOLE MATRIX INCLUDING PARTS C WHICH WILL NOT BE TRANSFORMED. C C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX; C C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY; C C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE C REDUCTION BY TRED2, IF PERFORMED. IF THE EIGENVECTORS C OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN C THE IDENTITY MATRIX. C C ON OUTPUT:D C C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT C UNORDERED FOR INDICES 1,2,...,IERR-1; C C E HAS BEEN DESTROYED; C C Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC C TRIDIAGONAL (OR FULL) MATRIX. IF AN ERROR EXIT IS MADE, C Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED C EIGENVALUES; C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C J IF THE J-TH EIGENVALUE HAS NOT BEEN C DETERMINED AFTER 30 ITERATIONS. C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW, C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY C C ------------------------------------------------------------------ C C C THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC. C MACHEP = 16.0E0**(-13) FOR LONG FORM ARITHMETIC C ON S360 MACHEP=1.E-16 N=NM IERR = 0 IF (N .EQ. 1) GO TO 1001 DO 100 I = 2, N E(I-1) = E(I) 100 CONTINUE F = 0.0 B = 0.0 E(N) = 0.0 DO 240 L = 1, N J = 0 H = MACHEP * ( ABS(D(L)) + ABS(E(L))) IF (B .LT. H) B = H C DO 110 M = L, N IF ( ABS(E(M)) .LE. B) GO TO 120 C C THROUGH THE BOTTOM OF THE LOOP 110 CONTINUE 120 IF (M .EQ. L) GO TO 220 130 IF (J .EQ. 30) GO TO 1000 J = J + 1 C L1 = L + 1 G = D(L) P = (D(L1) - G) / (2.0 * E(L)) R = SQRT(P*P+1.0) D(L) = E(L) / (P + SIGN(R,P)) H = G - D(L) DO 140 I = L1, N D(I) = D(I) - H 140 CONTINUE F = F + H C P = D(M) C = 1.0 S = 0.0 MML = M - L C DO 200 II = 1, MML I = M - II G = C * E(I) H = C * P IF ( ABS(P) .LT. ABS(E(I))) GO TO 150 C = E(I) / P R = SQRT(C*C+1.0) E(I+1) = S * P * R S = C / R C = 1.0 / R GO TO 160 150 C = P / E(I) R = SQRT(C*C+1.0) E(I+1) = S * E(I) * R S = 1.0 / R C = C * S 160 P = C * D(I) - S * G D(I+1) = H + S * (C * G + S * D(I)) C DO 180 K = 1, N H = Z(K,I+1) Z(K,I+1) = S * Z(K,I) + C * H Z(K,I) = C * Z(K,I) - S * H 180 CONTINUE 200 CONTINUE E(L) = S * P D(L) = C * P IF ( ABS(E(L)) .GT. B) GO TO 130 220 D(L) = D(L) + F 240 CONTINUE C DO 300 II = 2, N I = II - 1 K = I P = D(I) DO 260 J = II, N IF (D(J) .GE. P) GO TO 260 K = J P = D(J) 260 CONTINUE IF (K .EQ. I) GO TO 300 D(K) = D(I) D(I) = P DO 280 J = 1, N P = Z(J,I) Z(J,I) = Z(J,K) Z(J,K) = P 280 CONTINUE 300 CONTINUE GO TO 1001 C C EIGENVALUE AFTER 30 ITERATIONS 1000 IERR = L 1001 RETURN C END SUBROUTINE TRED2(NM,NN,A,D,E,Z) IMPLICIT REAL*8 ( A-H,O-Z ) C C ****************************************** INTEGER I,J,K,L,N,II,NM,JP1,NN REAL*8A(NN,NN),D(NN),E(NN),Z(NN,NN) REAL*8F,G,H,HH,SCALE C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED2, C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). C C THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX TO A C SYMMETRIC TRIDIAGONAL MATRIX USING AND ACCUMULATING C ORTHOGONAL SIMILARITY TRANSFORMATIONS. C C ON INPUT:D C C NM IS DIMENSION OF MATRIX ACTUALLY TRANSFORMED. C C NN IS THE DIMENSION OF THE WHOLE MATRIX INCLUDING PARTS C WHICH WILL NOT BE TRANSFORMED. C C A CONTAINS THE REAL SYMMETRIC INPUT MATRIX. ONLY THE C LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED. C C ON OUTPUT:D C C D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX; C C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO; C C Z CONTAINS THE ORTHOGONAL TRANSFORMATION MATRIX C PRODUCED IN THE REDUCTION; C C A AND Z MAY COINCIDE. IF DISTINCT, A IS UNALTERED. C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW, C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY C C ------------------------------------------------------------------ C N=NM DO 100 I = 1, N DO 105 J = 1, I Z(I,J) = A(I,J) 105 CONTINUE 100 CONTINUE IF (N .EQ. 1) GO TO 320 C DO 300 II = 2, N I = N + 2 - II L = I - 1 H = 0.0 SCALE = 0.0 IF (L .LT. 2) GO TO 130 C DO 120 K = 1, L SCALE = SCALE + ABS(Z(I,K)) 120 CONTINUE IF (SCALE) 140,130,140 130 E(I) = Z(I,L) GO TO 290 140 DO 150 K = 1, L Z(I,K) = Z(I,K) / SCALE H = H + Z(I,K) * Z(I,K) 150 CONTINUE F = Z(I,L) G = - SIGN( SQRT(H),F) E(I) = SCALE * G H = H - F * G Z(I,L) = F - G F = 0.0 DO 240 J = 1, L Z(J,I) = Z(I,J) / H G = 0.0 C DO 180 K = 1, J G = G + Z(J,K) * Z(I,K) 180 CONTINUE JP1 = J + 1 IF (L .LT. JP1) GO TO 220 DO 200 K = JP1, L G = G + Z(K,J) * Z(I,K) 200 CONTINUE C 220 E(J) = G / H F = F + E(J) * Z(I,J) 240 CONTINUE HH = F / (H + H) C DO 260 J = 1, L F = Z(I,J) G = E(J) - HH * F E(J) = G DO 265 K = 1, J Z(J,K) = Z(J,K) - F * E(K) - G * Z(I,K) 265 CONTINUE 260 CONTINUE 290 D(I) = H 300 CONTINUE 320 D(1) = 0.0 E(1) = 0.0 C DO 500 I = 1, N L = I - 1 IF (D(I)) 330,380,330 330 DO 360 J = 1, L G = 0.0 DO 340 K = 1, L G = G + Z(I,K) * Z(K,J) 340 CONTINUE DO 365 K = 1, L Z(K,J) = Z(K,J) - G * Z(K,I) 365 CONTINUE 360 CONTINUE 380 D(I) = Z(I,I) Z(I,I) = 1.0 IF (L .LT. 1) GO TO 500 DO 400 J = 1, L Z(I,J) = 0.0 Z(J,I) = 0.0 400 CONTINUE 500 CONTINUE RETURN C END