PROGRAM ROTFIT c my insertion USE MSFLIB USE MSIMSL 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 19february 2001: IK minor changes to ethylacetamidoacetate c see ik or cjth line C************************************************************************ CHARACTER ABC*834 CHARACTER*6 PARA,REF CHARACTER*1 PR,PROBS PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1 1,NN=(30)+1,ISIGMA=(2)) COMMON/EIGEN/HR(NDMX,NDMX),HI(NDMX,NDMX),WORK(NDMX), *EGVC3R(KDMX,9),EGVC3I(KDMX,9),NBR(2),VECTPR(10,961,KDMX,9) *,VECTPI(10,961,KDMX,9) COMMON/EIGEN1/EGVL(2*NDMX),EGVC(NDMX,2*NDMX) *,EGVCR(NDMX,2*NDMX),EGVCI(NDMX,2*NDMX) COMMON/TOR/A(9,NTORMX,2*KDMX,NN,ISIGMA),ETOR(2*KDMX,9) COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS COMMON/FACTS/GAM(1000) 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/DERIVR(10,961,80),ENER(10,961),DERIVI(10,961,80) DATA ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS/ 1 0.0E 00,0.1E 00,0.5E 00,1.0E 00,2.0E 00,3.0E 00,4.0E 00, 2 7.0E 00,1.1E 01,1.0E-08/ DATA CONV2/1.438769/ COMMON/EXPDAT / ETRANS(20000),IVOBS(2,20000), * NOBS(2,20000),KOBS(2,20000),IBLK(2,20000),IW(20000),W(20000), * NDATA,NADAT,EPSI,NOFIT,NFITMW,NFITIR,NFIMW0 ,NFIMW1 ,NITT, * IAST(20000),NFI004 ,NFI080 ,NFI100 ,NFI020 ,NFI200 ,NFI045 , & NGST0 ,NFI010 ,SW070,NFI070 ,NFIMW2,IKAKC,JMAX,NFI1M0, & NFIR10,NFIR21,NFIR32,NFIMW3,NFIMW4,SWA,SWE,NFITMWA,NFITMWE &,INT COMMON/CNTL/NIT,IEND,DELTAS,S,TME(20000),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,IISIG COMMON/CHARA/PARA(2,160),PR,PROBS(2,20000),REF(20000) DIMENSION CST(2,139),VTLDV(160,160),DELTAX (160) DIMENSION UNIT(160,160),VTLDVI(160,160) DIMENSION WKSPCE(160),DELX(160),DELXST(160),IBLSTO(2) DIMENSION IPIV(160) INTEGER N, LDA, LWORK, INFO,IFAIL DIMENSION VR(160),VI(160),V1R(160),V1I(160),V2R(160),V2I(160) DIMENSION VTLDTMR(160) DIMENSION VTLDTM (160) DIMENSION VTLDTMI(160) DIMENSION AINCER(20000) complex(8) Y,YCONJ,VTLDVC(160,160),VTLDTM,YY complex(8) A c my insertion integer*2 ihr, imin, isec, i100th c my insertion open(9,file='enerace.A') open(10,file='enerace.E') C REAL*8 SEC,TCPU C C THIS PROGRAM MAY TRAIT (20000) 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 open(unit=6,file='output.txt',access='sequential',status='unknown') WRITE(6,*) ' BEGIN PROGRAM ' write(6,*) 'this program belgieaaj30.i5sign.f on amur has the !sign (Pg-rhoPa)' 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.d0 30 CONTINUE 25 DO 2 I=1,NPP VR(I)=0.d0 VI(I)=0.d0 VTLDTMR(I)=0.d0 VTLDTM (I)=(0.d0,0.d0) VTLDTMI(I)=0.d0 DO 3 J=1,NPP VTLDV(I,J)=0.d0 VTLDVI(I,J)=0.d0 VTLDVC(I,J)=(0.d0,0.d0) 3 CONTINUE 2 CONTINUE DO 666 IA=1,NDATA AINCER(IA)=0.d0 666 CONTINUE CALL FACTT IBLSTO(1)=0.d0 IBLSTO(2)=0.d0 S=0.d0 SMW=0.d0 SIR=0.d0 SIR10=0.d0 SIR21=0.d0 SIR32=0.d0 SMW0=0.d0 SMW1=0.d0 SMW2=0.d0 SMW3=0.d0 SMW4=0.d0 SIG004=0.d0 SIG080=0.d0 SIG010=0.d0 SIG100=0.d0 SIG020=0.d0 SIG200=0.d0 SIG045=0.d0 SIG1M0=0.d0 SGST0=0.d0 SW070=0.d0 SWA=0.d0 SWE=0.d0 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.0 NFITMWE=0.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 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 c we need juan's table even for calculated lines IF (IAST(K).EQ.0) GO TO 4 NOFIT=NOFIT+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).GE.1000) NFITMW=NFITMW+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) 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 c IF(NITT.EQ.0) GO TO 4 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 V1I(I)=0.d0 V2I(I)=0.d0 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 V1R(I)= DERIVR(IVV,INK,I) V1I(I)= DERIVI(IVV,INK,I) ELSE V2R(I)=DERIVR(IVV,INK,I) V2I(I)=DERIVI(IVV,INK,I) ENDIF VR(I)=V2R(I)-V1R(I) VI(I)=V2I(I)-V1I(I) c if(N.EQ.2.and.isig.eq.0) c 1 print*,'VRdans main=',VR(I),'V2R=',V2R(I),'V1R=',V1R(I) c 2,'VI=',VI(I),'V2I=',V2I(I),'V1I=',V1I(I) c if(I.EQ.1.OR.I.EQ.6) THEN c if(I.EQ.13) then c print*,'VR=',VR(I),'V1R=',V1R(I),'V2R=',V2R(I),'I=',I,'K=',K c print*,'VI=',VI(I),'V1I=',V1I(I),'V2I=',V2I(I),'I=',I,'K=',K c &,'W=',W(K) c endif 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,v2r(1),v2r(2),v2r(3),v2r(4), 2 v1r(1),v1r(2),v1r(3),v1r(4) 1332 format(4i3,f15.5,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 VR(NPP)=1.d0 VI(NPP)=0.d0 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 YCONJ=dCMPLX(VR(I),-VI(I)) Y=dCMPLX(VR(J),VI(J)) YY=Y*YCONJ c VTLDV(I,J)=VTLDV(I,J)+V(I)*V(J)*W(K) VTLDVC(I,J)=VTLDVC(I,J)+YY*W(K) VTLDV(I,J)=dREAL(VTLDVC(I,J)) VTLDVI(I,J)=dIMAG(VTLDVC(I,J)) if(N.EQ.2.and.isig.eq.0) then c print*,'vtldv=',vtldv(I,J),'YY=',YY,'YCONJ=',YCONJ c 1,'Y=',Y,'K=',K,'I=',I,'J=',J,'W=',W(K),'vtldvi=',vtldvi(I,J) endif 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.2458d0 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) 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 VTLDTMR(I)=VTLDTMR(I)+VR(I)*TME(K)*W(K) VTLDTMI(I)=VTLDTMI(I)+VI(I)*TME(K)*W(K) VTLDTM(I)=dCMPLX(VTLDTMR(I),VTLDTMI(I)) c print*,'vtldtm=',vtldtm(I),'TME=',TME(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 write(6,*)'S(BEFORE FITTING)= ',S S=SQRT(S/(NOFIT-NPP)) IF(NFITMW.EQ.0) THEN SMW=0.d0 ELSE SMW=SQRT(SMW/NFITMW) ENDIF IF(NFITMWA.EQ.0) THEN SMWA=0.0 ELSE SMWA=SQRT(SMWA/NFITMWA) ENDIF IF(NFITMWE.EQ.0) THEN SMWE=0.0 ELSE SMWE=SQRT(SMWE/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 write(6,*)' 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=',SMWA, & ' NFITMWA=',NFITMWA,'SMWE=',SMWE,'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) CALL MATOUT(VTLDVI,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)= dSQRT(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)) c print*,'vtldv=',vtldv(I,J),'delx(i)=',delx(i),'delx(j)=', c 1delx(j),'i=',i,'j=',j 14 CONTINUE 13 CONTINUE IF(IBGVTD .NE.0) THEN WRITE(6,51) CALL MATOUT(VTLDV,160,160,NPP,NPP) CALL MATOUT(VTLDVI,160,160,NPP,NPP) ENDIF C C INVERSION OF THE VTLDV MATRIX.FROM THIS POINT,VTLDV C BECOMES THE INVERSE MATRIX C c CALL F01AAE(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)) c if(I.EQ.9.AND.J.EQ.9)print*,'vtldv=',vtldv(I,J) c 1,'delx(i)=',delx(i),'delx(j)=',delx(j),'unit=',unit(i,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 c I multiply vtldtm by i to make it real? DELX(I)= VTLDV(I,K)*VTLDTM (K)+DELX(I) c print*,'DELX=',DELX(I),'I=',I,'VTLDV=',VTLDV(I,K), c 1'VTLDTM=',VTLDTM(K),'K=',K 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)=dSQRT(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 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,AINCER) 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 END C************************************************************** SUBROUTINE ASET(K,EGVL,EGVCR,EGVCI,ETOR,A,CST) IMPLICIT REAL*8 ( A-H,O-Z ) C************************************************************ C STORAGE OF THE COEFICIENTS OF THE TORSION EIGENVECTORS C CHARACTER ABC*834 CHARACTER*1 PR,PROBS CHARACTER*6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1 1,NN=(30)+1,ISIGMA=(2)) 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,IISIG COMMON/CHARA/PARA(2,160),PR,PROBS(2,20000),REF(20000) DIMENSION EGVL(NDMX),EGVCR(NDMX,NDMX),ETOR(KDMX,9) DIMENSION EGVCI(NDMX,NDMX),CST(2,139),BR(9,NTORMX,KDMX) DIMENSION BI(9,NTORMX,KDMX) complex(8) E(NDMX,NDMX) complex(8) A(9,NTORMX,2*KDMX,NN,ISIGMA) IK=K+N +1 NP1=N+1 c V3I=CST(LO,133) DO 1 I=1,(09) DO 2 J=1,NDIMTO E(J,I)=dCMPLX(EGVCR(J,I),EGVCI(J,I)) A(I,J,IK,NP1,IISIG)=E(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((dREAL(A(I,10,IK,NP1,IISIG))/dREAL(A(I,10,IK-1,NP1,IISIG))) 1.LT.0.0) THEN DO 4 J=1,NDIMTO A(I,J,IK,NP1,IISIG)=-A(I,J,IK,NP1,IISIG) 4 CONTINUE ENDIF IF(N.EQ.0) GO TO 16 IF((dREAL(A(I,10,IK,NP1,IISIG))/dREAL(A(I,10,IK-1,NP1-1,IISIG))) 1.LT.0.0) THEN DO 5 J=1,NDIMTO A(I,J,IK,NP1,IISIG)=-A(I,J,IK,NP1,IISIG) 5 CONTINUE ENDIF 3 CONTINUE 16 RETURN END C************************************************************ C SUBROUTINE CNTRL(NPP,DELX,DELTAXL,CST) C************************************************************ C MONITORS THE FITTING(CONCONVERGENCE,REJECTION OF TRANSITIONS, C DIVERGENCE) C C CHARACTER*6 PARA,REF C CHARACTER*1 PR,PROBS C INTEGER REJ C COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRONC1, C 1IBGTME,IBGVTDV,EVIB(2),IRMW,TERM C COMMON/PAR/IND(2,80),NP(2),X(160),ITO C COMMON/EXPDATA/ ETRANS(20000),IVOBS(2,20000), C 1NOBS(2,20000),KOBS(2,20000),IBLK(2,20000),IW(20000),W(20000), C 2NDATA,NADAT,EPSI,NOFIT,NFITMW,NFITIR,NFITMW0,NFITMW1,NITT, C 3IAST(20000),NFIT004,NFIT080,NFIT100,NFIT020,NFIT200,NFIT045,NGST0 C 4,NFIT010,IKAKC C COMMON/CNTL/NIT,IEND,DELTAS,S,TME(20000),TERMST,NP12,SMW,SIR, C 1SMW0,SMW1,SIG004,SIG080,SIG10,SIG100,SIG020,SIG200,SIG045,SGST0 C COMMON/CHARA/PARA(2,160),PR,PROBS(2,20000),REF(20000) C DIMENSION DELX(160),DELTAXL(160),CST(2,139) C I = 1 C6 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 STOP C END IF C IF(NIT.GT.NITT) STOP C IEND = 1 C WRITE(6,307) NIT C NIT = NIT + 1 C RETURN C END IF C I = I + 1 C IF (I .LE. NPP) GO TO 6 C C REJ = 0 C CALL REJEC(TME,S,REJ) C IF (REJ .EQ. 0) THEN C WRITE(6,*) ' PROGRAM HAS CONVERGED AFTER ',NIT, C 1 ' ITERATIONS' C IEND = 0 C RETURN C ELSE C DO 94 I = 1,NP12 C IF (I .GT. NP(1)) THEN C II = 2 C J = I - NP(1) C ELSE C II = 1 C J = I C END IF C CST(II,IND(II,J)) = X(I) C94 CONTINUE C TERM = TERMST C IEND = -1 C WRITE(6,807) C RETURN C END IF C307 FORMAT(/,' *** END OF CYCLE NO. ',I3,' *** ') C807 FORMAT(//,' *** NEW LEAST SQUARE FITTING PROCEDURE ***', C 1 /,' ==========================================') C 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(20000),IVOBS(2,20000), * NOBS(2,20000),KOBS(2,20000),IBLK(2,20000),IW(20000),W(20000), * NDATA,NADAT,EPSI,NOFIT,NFITMW,NFITIR,NFIMW0 ,NFIMW1 ,NITT, * IAST(20000),NFI004 ,NFI080 ,NFI100 ,NFI020 ,NFI200 ,NFI045 , & NGST0 ,NFI010 ,SW070,NFI070 ,NFIMW2,IKAKC,JMAX,NFI1M0, & NFIR10,NFIR21,NFIR32,NFIMW3,NFIMW4,SWA,SWE,NFITMWA,NFITMWE &,INT COMMON/CNTL/NIT,IEND,DELTAS,S,TME(20000),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,20000),REF(20000) DIMENSION DELX(160),DELTAX (160),CST(2,139) 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=dABS(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) 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*834 CHARACTER*1 PROBS,PR,PRINF,PRSUP CHARACTER*6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1 1,NN=(30)+1,ISIGMA=(2)) 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(20000),IVOBS(2,20000), * NOBS(2,20000),KOBS(2,20000),IBLK(2,20000),IW(20000),W(20000), * NDATA,NADAT,EPSI,NOFIT,NFITMW,NFITIR,NFIMW0 ,NFIMW1 ,NITT, * IAST(20000),NFI004 ,NFI080 ,NFI100 ,NFI020 ,NFI200 ,NFI045 & ,NGST0 ,NFI010 ,SW070,NFI070 ,NFIMW2,IKAKC,JMAX,NFI1M0, & NFIR10,NFIR21,NFIR32,NFIMW3,NFIMW4,SWA,SWE,NFITMWA,NFITMWE &,INT COMMON/SYMB/ABC COMMON/CHARA/PARA(2,160),PR,PROBS(2,20000),REF(20000) COMMON/INT/TPR,BLTZ,CONV2,SSQ,BLTZ2 DIMENSION CST(2,139) c my insertion open(unit=5,file='input.txt',access='sequential',status='old') WRITE(6,*) ' THIS OUTPUT IS FROM belgieaaj30.i5int.f' 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,INT,TPR,ISYM WRITE(6,*) ' VIB.ENERGY TO BE FITTED? ITO= ',ITO WRITE(6,*)' NUMBER OF ITERATIONS= ',NITT WRITE(6,*)' MAXIMUM VALUE OF J= ',JMAX WRITE(6,*)' INTENSITE?(1/0)=',INT WRITE(6,*)' TEMPERATURE=',TPR 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) cijk I have put the "fake" asymmetric lines weights to zero if(IW(I).EQ.1200.and.ref(i).eq.'calcul') iast(i)=0 c to transfer to "-"sign c if(probs(2,i).eq.'')then c kobs(2,i)=-kobs(2,i) c kobs(1,i)=-kobs(1,i) c endif c 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 c if(ivobs(1,i).eq.2.and.ivobs(2,i).eq.2) 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 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 ccdebugik jul21,2003, change of sign of Pg-rho.Pa c if(probs(1,I).eq.' ') then c KOBS(1,I)=-KOBS(1,I) c KOBS(2,I)=-KOBS(2,I) c endif 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! 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.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.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 ELSEIF(IW(I).EQ.1000.AND.IVOBS(1,I).EQ.2) 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 c put all E species at zero weight c if(I.gt.nadat) iast(i)=0 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) 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 ccdebugik jul21,2003, change of sign of Pg-rho.Pa c if(probs(1,I).eq.' ') then c KOBS(1,I)=-KOBS(1,I) c KOBS(2,I)=-KOBS(2,I) c endif 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(2,I),NOBS(2,I),KOBS(2,I) A,PROBS(2,I),IBLK(2,I),IVOBS(1,I),NOBS(1,I),KOBS(1,I) B,PROBS(1,I),IBLK(1,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 write(6,*)NDATA,NADAT ENDIF C C NADAT:DNBREOF DATA A TYPE(SIGMA=0);NDATA:DNBRE OF TOTAL DATA C IF(NDATA.GT.(20000))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,A1) 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,A1) 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 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*834 CHARACTER*1 PR,PROBS CHARACTER*4 ANSWER CHARACTER*6 PARA,REF COMMON/SYMB/ABC COMMON/CHARA/PARA(2,160),PR,PROBS(2,20000),REF(20000) COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRON1 , * IBGTME,IBGVTD ,EVIB(2),IRMW,TERM DIMENSION CST(2,139) 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 DACI,DACJI,ODACI,FVI,OFVI,ANVI,V12JI,V12KI,ANVJI,BK2I, & BK2JI,AK5I,AK5JI,AK5KI,AK7I,AK7KI,AK7JI,C2I,C2JI,C2KI, & C11I,ODABI,ODABJI,ODAB6I,DBCI,ODBCI, 9 F,RHO,V3,V6,V9,V12,V3I,RHORHO,AMUA0,AMUA3,AMUB0,AMUB3,AMUC3 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:834)= '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 DACI DACJI ODACI FVI OFVI ANVI V12JI V12KI ANVJI &BK2I BK2JI AK5I AK5JI AK5KI AK7I AK7KI AK7JI C2I C2JI C2KI &C11I ODABI ODABJIODAB6IDBCI ODBCI F RHO V3 V6 V9 &V12 V3I RHORHOAMUA0 AMUA3 AMUB0 AMUB3 AMUC3 ' C INITIALISATION C OA=0.d0 B=0.d0 C=0.d0 DJ=0.d0 DJK=0.d0 DK=0.d0 ODELN=0.d0 ODELK=0.d0 HJ=0.d0 HJK=0.d0 HKJ=0.d0 HK=0.d0 OHJ=0.d0 OHJK=0.d0 OHK=0.d0 FV=0.d0 OFV=0.d0 GV=0.d0 ALV=0.d0 AK1=0.d0 AK2=0.d0 AK3=0.d0 AK4=0.d0 AK5=0.d0 AK6=0.d0 AK7=0.d0 DAB=0.d0 DBC=0.d0 DBCI=0.d0 ODBCI=0.d0 C4=0.d0 ODELTA=0.d0 AK1J=0.d0 AK5K=0.d0 AK2K=0.d0 AK1K=0.d0 AK3J=0.d0 AK3K=0.d0 DELTA=0.d0 ODAB=0.d0 DABJ=0.d0 DABK=0.d0 OLV=0.d0 C1=0.d0 C2=0.d0 C3=0.d0 HLKJ=0.d0 AK5J=0.d0 C2J=0.d0 GVJ=0.d0 AK2J=0.d0 C1J=0.d0 ANV=0.d0 BK2=0.d0 AMV=0.d0 DAC=0.d0 DBC12=0.d0 DAC12=0.d0 BK1=0.d0 AK7J=0.d0 C11=0.d0 ODAB6=0.d0 AK6K=0.d0 AK7K=0.d0 AK66=0.d0 AK6J=0.d0 AK3B=0.d0 AK4B=0.d0 DELTAB=0.d0 ODELTB=0.d0 C4J=0.d0 C4K=0.d0 C1K=0.d0 C2K=0.d0 C12=0.d0 ANVJ=0.d0 AMVJ=0.d0 AK3JJ=0.d0 BK2J=0.d0 BK1J=0.d0 AK3KJ=0.d0 F=0.d0 RHO=0.d0 V3=0.d0 V3I=0.d0 V6=0.d0 V9=0.d0 V12=0.d0 V12J=0.d0 V12K=0.d0 BK1K=0.d0 AK3KK=0.d0 C3J=0.d0 C12J=0.d0 AK2JJ=0.d0 AK1JJ=0.d0 AK2JK=0.d0 AK1JK=0.d0 AK3BJ=0.d0 AK4BJ=0.d0 AK3BB=0.d0 AK4BB=0.d0 ESPOIR=0.d0 DACJ=0.d0 DBCJ=0.d0 ODABJ=0.d0 RHOB=0.d0 RHOC=0.d0 AK9=0.d0 C RHOJ=0.0 C RHOK=0.0 RHORHO=0.d0 DACI=0.d0 DACJI=0.d0 ODACI=0.d0 FVI=0.d0 OFVI=0.d0 ANVI=0.d0 V12JI=0.d0 V12KI=0.d0 ANVJI=0.d0 BK2I=0.d0 BK2JI=0.d0 AK5I=0.d0 AK5JI=0.d0 AK5KI=0.d0 AK7I=0.d0 AK7JI=0.d0 AK7KI=0.d0 C2I=0.d0 C2JI=0.d0 C2KI=0.d0 C11I=0.d0 ODABI=0.d0 ODABJI=0.d0 ODAB6I=0.d0 AMUA0=0.d0 AMUA3=0.d0 AMUB0=0.d0 AMUB3=0.d0 AMUBC=0.d0 C C INITIALISATION C DO 3 II=1,(139) CST(LO,II)=0.d0 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.2458d0 C READ FROM NAMELIST READ(5,CSTE) WRITE(6,CSTE) C PUT THE CONSTANT VALUES IN CST VECTOR 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 ,DACI,DACJI,ODACI,FVI,OFVI,ANVI,V12JI,V12KI,ANVJI,BK2I, & BK2JI,AK5I,AK5JI,AK5KI,AK7I,AK7KI,AK7JI,C2I,C2JI,C2KI, & C11I,ODABI,ODABJI,ODAB6I,DBCI,ODBCI, & F,RHO,V3,V6,V9,V12,V3I,RHORHO,AMUA0,AMUA3,AMUB0,AMUB3,AMUC3 REWIND 35 READ(35) (CST(LO,II),II=1,(139)) REWIND 35 DO 18 III=1,124 CST(LO,III)=CST(LO,III)/CONV 18 CONTINUE c V3I=CST(LO,127)*0.6 c CST(LO,131)=CST(LO,127)*0.6 c FVI=CST(LO,16)*0.6 c CST(LO,104)=CST(LO,16)*0.6 c AK5I=CST(LO,24)*0.6 c CST(LO,112)=CST(LO,24)*0.6 c C2I=CST(LO,33)*0.6 c CST(LO,118)=CST(LO,33)*0.6 c ODABI=CST(LO,28)*0.6 c CST(LO,122)=CST(LO,28)*0.6 c V3=CST(LO,129)*0.8 c CST(LO,127)=CST(LO,127)*0.8 c FV=CST(LO,16)*0.8 c CST(LO,16)=CST(LO,16)*0.8 c AK5=CST(LO,24)*0.8 c CST(LO,24)=CST(LO,24)*0.8 c C2=CST(LO,33)*0.8 c CST(LO,33)=CST(LO,33)*0.8 c ODAB=CST(LO,28)*0.8 c CST(LO,28)=CST(LO,28)*0.8 c write(6,*) 'constantes after change' c do II=1,132 c print*,'cst(lo,II)=',cst(lo,II),'lo=',lo,'II=',II c132 continue c PRINT*,CST(LO,38) C PRINT*,RHO,CST(LO,1) RETURN END C*********************************************************** SUBROUTINE ENCAL(E,LO,EGVL,EGVCR,EGVCI,A) 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 1,NN=(30)+1,ISIGMA=(2)) COMMON/EIGEN/HR(NDMX,NDMX),HI(NDMX,NDMX),WORK(NDMX), *EGVC3R(KDMX,9),EGVC3I(KDMX,9),NBR(2),VECTPR(10,961,KDMX,9) *,VECTPI(10,961,KDMX,9) COMMON/ROTOR/NROTOR,NDIMTO COMMON/QUANT/ISIG,IV,N,KK,IISIG COMMON/QUANT2/KKK(NDMX),NVT(NDMX),IPRITY(NDMX) COMMON/C2C/PERC2L,PER23L(NDMX) COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRON1 , * IBGTME,IBGVTD ,EVIB(2),IRMW,TERM COMMON/CHARA/PARA(2,160),PR,PROBS(2,20000),REF(20000) DIMENSION EGVL(NDMX),EGVCR(NDMX,NDMX) complex(8) PERC2L,PER23L complex(8) A(9,NTORMX,2*KDMX,NN,ISIGMA) DIMENSION EGVCI(NDMX,NDMX) DIMENSION EGVC4R(KDMX,NTORMX,NDMX) DIMENSION EGVC4I(KDMX,NTORMX,NDMX) nbr(LO)=1 C TAKE THE GOOD EIGENVALUE(E) AND ASSOCIATE A NUMBER(NBR) C TO THE EIGENVECTOR CORRESPONDING TO THE K DATA 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) EGVC4R(II,IVTORP,J)=EGVCR(I,J) EGVC4I(II,IVTORP,J)=EGVCI(I,J) C IF(N.EQ.1.AND.J.LE.12) THEN C PRINT*,'EGVC4R=',EGVC4R(II,IVTORP,J),'II=',II,'J=',J C 1,'IVTORP=',IVTORP,'EGVCR=',EGVCR(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(KK.EQ.0.AND.IV.EQ.0)THEN NBR(LO)=IPOSA(EGVCR,EGVCI,EGVL,A,EGVC4R,EGVC4I) ELSE NBR(LO)=IPOSA2(EGVCR,EGVCI,EGVL,A,EGVC4R,EGVC4I,PR) ENDIF ELSE IF(KK.EQ.(-N).AND.IV.EQ.0) THEN NBR(LO)=IPOSE(EGVCR,EGVCI,EGVL) ELSE NBR(LO)=IPOSE2(EGVCR,EGVCI,EGVL) ENDIF ENDIF C PRINT*,' NBR= ',NBR(LO),' LO= ',LO if(nbr(LO).gt.ndmx)nbr(LO)=ndmx if(nbr(LO).lt.1)nbr(LO)=1 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) EGVC3R(II,IVTORP)=EGVCR(I,NBR(LO)) EGVC3I(II,IVTORP)=EGVCI(I,NBR(LO)) c if(N.EQ.2) print*,'EGVC3R dans encal=',EGVC3R(II,IVTORP) c 1,'EGVC3I=',EGVC3I(II,IVTORP),'II=',II,'ivtorp=',ivtorp IF(IVTORP.GE.9) EGVC3R(II,IVTORP)=0.0 IF(IVTORP.GE.9) EGVC3I(II,IVTORP)=0.0 C PRINT*,' EGVCR(I,NBR(LO))= ',EGVCR(I,NBR(LO)) C PRINT*,' EGVC3R= ',EGVC3R(II,IVTORP),' IVTORP= ',IVTORP 3 CONTINUE RETURN END C********************************************************** C********************************************************** C FUNCTION H0 (K,IVTOR,KP,IVTORP,CST,LO,ETOR,A) C*********************************************************** C SETS UP THE DIAGONAL ELEMENTS OF THE HAMILTONIAN C CHARACTER ABC*834 C CHARACTER*1 PR,PROBS C CHARACTER*6 PARA,REF C PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1) C COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRONC1, C 1IBGTME,IBGVTDV,EVIB(2),IRMW,TERM C COMMON/CHARA/PARA(2,160),PR,PROBS(2,20000),REF(20000) C COMMON/ROTOR/NROTOR,NDIMTOR C COMMON/SYMB/ABC C COMMON/QUANT/ISIG,IV,N,KK C DIMENSION CST(2,139),A(9,NTORMX,KDMX),ETOR(KDMX,9) C OA=CST(LO,1) C B=CST(LO,2) C C=CST(LO,3) C DJ=CST(LO,4) C DJK=CST(LO,5) C DK=CST(LO,6) C ODELN=CST(LO,7) C ODELK=CST(LO,8) C HJ=CST(LO,9) C HJK=CST(LO,10) C HKJ=CST(LO,11) C HK=CST(LO,12) C OHJ=CST(LO,13) C OHJK=CST(LO,14) C OHK=CST(LO,15) C FV=CST(LO,16) C OFV=CST(LO,17) C GV=CST(LO,18) C ALV=CST(LO,19) C AK1=CST(LO,20) C AK2=CST(LO,21) C AK3=CST(LO,22) C AK4=CST(LO,23) C AK5=CST(LO,24) C AK6=CST(LO,25) C AK7=CST(LO,26) C DAB=CST(LO,27) C ODAB=CST(LO,28) C OLV=CST(LO,31) C C1=CST(LO,32) C C2=CST(LO,33) C C3=CST(LO,34) C HLKJ=CST(LO,35) C AK5J=CST(LO,36) C C2J=CST(LO,37) C GVJ=CST(LO,38) C AK2J=CST(LO,39) C C1J=CST(LO,40) C ANV=CST(LO,41) C BK2=CST(LO,42) C AMV=CST(LO,43) C RHO=CST(LO,102) C RHOJ=CST(LO,60) C RHOK=CST(LO,61) C IK=K+N +1 C INITIALISATION C A1=0.0 C A2=0.0 C A3=0.0 C A4=0.0 C A5=0.0 C A6=0.0 C A7=0.0 C DO 9 II=1,NDIMTOR C KL=II-KTRONC1 C COEFA= A(IVTOR,II,IK) C IF (II.EQ.NDIMTOR) THEN C COEFAA=0.0 C ELSE C COEFAA=A(IVTOR,II+1,IK) C ENDIF C IF(II.GT.(NDIMTOR-2)) THEN C COEFAAA=0.0 C ELSE C COEFAAA=A(IVTOR,II+2,IK) C ENDIF C RHOEFF=RHO+RHOJ*N*(N+1)+RHOK*K**2 C RHOKSIG=3.*KL+ISIG+RHOEFF*K C RHOKK=3*(KL+1)+ISIG+RHOEFF*K C A1=A1+COEFA*COEFAA C A2=A2+(COEFA*RHOKSIG)**2 C A3=A3+COEFA**2*RHOKSIG C A4=A4+COEFA**2*RHOKSIG**3 C A5=A5+COEFA**2*RHOKSIG**4 C A6=A6+COEFA*COEFAAA C A7=A7+COEFA*COEFAA*(RHOKSIG**2+RHOKK**2) C9 CONTINUE C PRINT*,' A1= ',A1,' A2= ',A2,' A3= ',A3,' A4= ',A4,' A5= ', C 1A5 C H0=0.5*(B+C)*(N*(N+1)-K**2)+OA*K**2 C H0=H0+(FV+OFV*N*(N+1))*(1.-A1)*N*(N+1) C H0=H0+(ANV*N*(N+1))*(1.-A6) C H0=H0+(1.-A6)*(K**2)*BK2 C H0=H0+GV*A2*N*(N+1) C H0=H0+GVJ*A2*N**2*(N+1)**2 C H0=H0+ALV*K*A3*N*(N+1) C H0=H0-K**2*DJK*N*(N+1) C H0=H0-N*(N+1)*DJ*N*(N+1) C H0=H0+AK1*K**3*A3 C H0=H0+AK2*K**2*A2 C H0=H0+AK2J*K**2*A2 C PRINT*,' H0= ',H0 C H0=H0+AK3*K*A4 C H0=H0+AK4*A5 C H0=H0+AMV*A5*N*(N+1) C H0=H0+AK5*K**2*(1.-A1) C H0=H0+AK5J*K**2*(1.-A1)*N*(N+1) C H0=H0+AK6*K*A3 C H0=H0+AK7*(A2-0.5*A7) C PRINT*,' AK7=',AK7,' A1=',A1,'RHOKSIG=',RHOKSIG,'RHOKK=', C 1RHOKK,'N=',N,'K=',K,'IVTOR=',IVTOR C H0=H0-DK*K**4 C H0=H0+HJ*(N*(N+1))**3 C H0=H0+HJK*(N*(N+1)*K)**2 C H0=H0+HKJ*N*(N+1)*K**4 C H0=H0+HLKJ*K**6*N*(N+1) C H0=H0+HK*K**6 C PRINT*,' CONV = ',CONV C H0 = H0/CONV C PRINT*,' H0= ',H0 C H0=H0+ETOR(IK,IVTOR) C PRINT*,ETOR(IK,IVTOR) C PRINT*,' H0= ',H0 C RETURN C END C********************************************************** 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*834 CHARACTER*1 PR,PROBS CHARACTER*6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1 1,NN=(30)+1,ISIGMA=(2)) COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRON1 , * IBGTME,IBGVTD ,EVIB(2),IRMW,TERM COMMON/CHARA/PARA(2,160),PR,PROBS(2,20000),REF(20000) COMMON/ROTOR/NROTOR,NDIMTO COMMON/SYMB/ABC COMMON/QUANT/ISIG,IV,N,KK,IISIG DIMENSION CST(2,139),ETOR(KDMX,9) COMPLEX(8) ETOR2(KDMX,9) COMPLEX(8) A(9,NTORMX,2*KDMX,NN,ISIGMA) COMPLEX(8) COEFA,COFAAA,COEFAA,COEFA4,COEFA5,COEFA6,COEFA7 COMPLEX(8) COEFA8 COMPLEX(8) H0 COMPLEX(8) A15B,A16,A16B,A17 COMPLEX(8) A1,A2,A3,A4,A4B,A4BB,A5,A5B,A5BB,A6,A7,A8,A8B,A9 COMPLEX(8) A9B,A10,A10B,A11,A11B,A12,A13,A18,A19,A14,A14B,A15 OA=CST(LO,1) B=CST(LO,2) C=CST(LO,3) FVI=CST(LO,104) 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) RHO=CST(LO,128) F=CST(LO,127) V3=CST(LO,129) V3I=CST(LO,133) V6=CST(LO,130) V9=CST(LO,131) V12=CST(LO,132) RHORHO=CST(LO,134) IK=K+N +1 NP1=N+1 C INITIALISATION A1=0.d0 A2=0.d0 A3=0.d0 A4=0.d0 A4B=0.d0 A4BB=0.d0 A5BB=0.d0 A5=0.d0 A5B=0.d0 A6=0.d0 A7=0.d0 A7=0.d0 A8=0.d0 A8B=0.d0 A9B=0.d0 A14B=0.d0 A15B=0.d0 A9=0.d0 A10=0.d0 A11=0.d0 A12=0.d0 A13=0.d0 A14=0.d0 A15=0.d0 A16=0.d0 A17=0.d0 A10B=0.d0 A11B=0.d0 A16B=0.d0 A17B=0.d0 A18=0.d0 A19=0.d0 DO 9 II=1,NDIMTO KL=II-KTRON1 COEFA= dCONJG(A(IVTOR,II,IK,NP1,IISIG)) COFAAA =A(IVTORP,II,IK,NP1,IISIG) IF (II.EQ.NDIMTO ) THEN COEFAA=0.0 ELSE COEFAA=A(IVTORP,II+1,IK,NP1,IISIG) ENDIF IF(II.EQ.1) THEN COEFA4=0.0 ELSE COEFA4=A(IVTORP,II-1,IK,NP1,IISIG) ENDIF IF(II.GT.(NDIMTO -2)) THEN COEFA5=0.0 ELSE COEFA5=A(IVTORP,II+2,IK,NP1,IISIG) ENDIF IF(II.LE.2) THEN COEFA6=0.0 ELSE COEFA6=A(IVTORP,II-2,IK,NP1,IISIG) ENDIF IF(II.GT.(NDIMTO -4)) THEN COEFA7=0.0 ELSE COEFA7=A(IVTORP,II+4,IK,NP1,IISIG) ENDIF IF(II.LE.4) THEN COEFA8=0.0 ELSE COEFA8=A(IVTORP,II-4,IK,NP1,IISIG) ENDIF C RHOEFF=RHO+RHOJ*N*(N+1)+RHOK*K**2 RHOEFF=RHO RHOKSG =3.d0*KL+ISIG+RHOEFF*K RHOKK=3.d0*(KL+1)+ISIG+RHOEFF*K RHOKK2=3.d0*(KL+2)+ISIG+RHOEFF*K RHOKM1=3.d0*(KL-1)+ISIG+RHOEFF*K RHOKM2=3.d0*(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 COEFA=(COEFA) 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 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.5d0*(B+C)*(N*(N+1)-K**2)+OA*K**2)*A6 c if(N.EQ.2) print*,'A6=',A6,'H0=',H0,'K=',K H0=H0+(FV+OFV*N*(N+1))*(A6-0.5d0*A7-0.5d0*A1)*N*(N+1) c if(N.EQ.2) print*,'A6=',A6,'H02=',H0 c 1,'A7=',A7,'A1=',A1,'K=',K H0=H0+(ANV*N*(N+1))*(A6-0.5d0*A13-0.5d0*A12) H0=H0+(V12J*N*(N+1))*(A6-0.5d0*A18-0.5d0*A19) H0=H0+(V12K*K**2)*(A6-0.5d0*A18-0.5d0*A19) H0=H0+(ANVJ*N*(N+1)*N*(N+1))*(A6-0.5d0*A13-0.5d0*A12) H0=H0+(A6-0.5d0*A12-0.5d0*A13)*(K**2)*BK2 H0=H0+(A6-0.5d0*A12-0.5d0*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.5d0*A7-0.5d0*A1) H0=H0+AK5K*K**4*(A6-0.5d0*A7-0.5d0*A1) H0=H0+AK5J*K**2*(A6-0.5d0*A7-0.5d0*A1)*N*(N+1) H0=H0+AK6*K*(A3-0.5d0*A8-0.5d0*A9+A3-0.5d0*A14-0.5d0*A15) H0=H0+AK66*K*(A3-0.5d0*A8B-0.5d0*A9B+A3-0.5d0*A14B-0.5d0*A15B) H0=H0+AK6K*K*(A3-0.5d0*A8-0.5d0*A9+A3-0.5d0*A14-0.5d0*A15)*K**2 H0=H0+AK6J*K*(A3-0.5d0*A8-0.5d0*A9+A3-0.5d0*A14-0.5d0*A15)*N*(N+1) H0=H0+AK7*(A2-0.5d0*A10-0.5d0*A11+A2-0.5d0*A16-0.5d0*A17) H0=H0+AK9*(A2-0.5d0*A10B-0.5d0*A11B+A2-0.5d0*A16B-0.5d0*A17B) H0=H0+AK7K*(A2-0.5d0*A10-0.5d0*A11+A2-0.5d0*A16-0.5d0*A17)*K**2 H0=H0+AK7J*(A2-0.5d0*A10-0.5d0*A11+A2-0.5d0*A16-0.5d0*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 ETOR2(IK,IVTOR)=dCMPLX(ETOR(IK,IVTOR),0.) IF(IVTOR.EQ.IVTORP) H0=H0+ETOR2(IK,IVTOR) c if(N.EQ.2) c 1PRINT*,'ETOR=',ETOR(IK,IVTOR),'ETOR2=',ETOR2(IK,IVTOR) c 2,'H0=',H0,'K=',K RETURN END C********************************************************** FUNCTION H0I (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*834 CHARACTER*1 PR,PROBS CHARACTER*6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1 1,NN=(30)+1,ISIGMA=(2)) COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRON1 , * IBGTME,IBGVTD ,EVIB(2),IRMW,TERM COMMON/CHARA/PARA(2,160),PR,PROBS(2,20000),REF(20000) COMMON/ROTOR/NROTOR,NDIMTO COMMON/SYMB/ABC COMMON/QUANT/ISIG,IV,N,KK,IISIG DIMENSION CST(2,139),ETOR(KDMX,9) complex(8) A(9,NTORMX,2*KDMX,NN,ISIGMA) complex(8) COEFA,COEFAA,COFAAA,COEFA4,COEFA5,COEFA6,COEFA7, 1COEFA8 complex(8) A15B,A16,A16B,A17 complex(8) A1,A2,A3,A4,A4B,A4BB,A5,A5B,A5BB,A6,A7,A8,A8B,A9 complex(8) A9B,A10,A10B,A11,A11B,A12,A13,A18,A19,A14,A14B,A15 complex(8) H0I FVI=CST(LO,104) OFVI=CST(LO,105) ANVI=CST(LO,106) V12JI=CST(LO,107) V12KI=CST(LO,108) ANVJI=CST(LO,109) BK2I=CST(LO,110) BK2JI=CST(LO,111) AK5I=CST(LO,112) AK5JI=CST(LO,113) AK5KI=CST(LO,114) AK7I=CST(LO,115) AK7KI=CST(LO,116) AK7JI=CST(LO,117) C2I=CST(LO,118) C2JI=CST(LO,119) C2KI=CST(LO,120) C11I=CST(LO,121) ODABI=CST(LO,122) ODABJI=CST(LO,123) ODAB6I=CST(LO,123) RHO=CST(LO,128) F=CST(LO,127) V3=CST(LO,129) V6=CST(LO,130) V9=CST(LO,131) V12=CST(LO,132) RHORHO=CST(LO,134) C RHOJ=CST(LO,60) C RHOK=CST(LO,61) IK=K+N +1 NP1=N+1 C INITIALISATION A1=0.d0 A2=0.d0 A3=0.d0 A4=0.d0 A4B=0.d0 A4BB=0.d0 A5BB=0.d0 A5=0.d0 A5B=0.d0 A6=0.d0 A7=0.d0 A7=0.d0 A8=0.d0 A8B=0.d0 A9B=0.d0 A14B=0.d0 A15B=0.d0 A9=0.d0 A10=0.d0 A11=0.d0 A12=0.d0 A13=0.d0 A14=0.d0 A15=0.d0 A16=0.d0 A17=0.d0 A10B=0.d0 A11B=0.d0 A16B=0.d0 A17B=0.d0 A18=0.d0 A19=0.d0 DO 9 II=1,NDIMTO KL=II-KTRON1 COEFA= dCONJG(A(IVTOR,II,IK,NP1,IISIG)) COFAAA =A(IVTORP,II,IK,NP1,IISIG) IF (II.EQ.NDIMTO ) THEN COEFAA=0.d0 ELSE COEFAA=A(IVTORP,II+1,IK,NP1,IISIG) ENDIF IF(II.EQ.1) THEN COEFA4=0.d0 ELSE COEFA4=A(IVTORP,II-1,IK,NP1,IISIG) ENDIF IF(II.GT.(NDIMTO -2)) THEN COEFA5=0.d0 ELSE COEFA5=A(IVTORP,II+2,IK,NP1,IISIG) ENDIF IF(II.LE.2) THEN COEFA6=0.d0 ELSE COEFA6=A(IVTORP,II-2,IK,NP1,IISIG) ENDIF IF(II.GT.(NDIMTO -4)) THEN COEFA7=0.d0 ELSE COEFA7=A(IVTORP,II+4,IK,NP1,IISIG) ENDIF IF(II.LE.4) THEN COEFA8=0.d0 ELSE COEFA8=A(IVTORP,II-4,IK,NP1,IISIg) ENDIF C RHOEFF=RHO+RHOJ*N*(N+1)+RHOK*K**2 RHOEFF=RHO RHOKSG =3.d0*KL+ISIG+RHOEFF*K RHOKK=3.d0*(KL+1)+ISIG+RHOEFF*K RHOKK2=3.d0*(KL+2)+ISIG+RHOEFF*K RHOKM1=3.d0*(KL-1)+ISIG+RHOEFF*K RHOKM2=3.d0*(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 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 H0I=(FVI+OFVI*N*(N+1))*(-0.5d0*A7+0.5d0*A1)*N*(N+1) c if(N.EQ.2) print*,'A7=',A7,'A1=',A1,'H0I=',H0I c 1,'K=',K,'dans la fontion' H0I=H0I+(ANVI*N*(N+1))*(-0.5d0*A13+0.5d0*A12) H0I=H0I+(V12JI*N*(N+1))*(0.5d0*A18-0.5d0*A19) H0I=H0I+(V12KI*K**2)*(0.5d0*A18-0.5d0*A19) H0I=H0I+(ANVJI*N*(N+1)*N*(N+1))*(-0.5d0*A13+0.5d0*A12) H0I=H0I+(0.5d0*A12-0.5d0*A13)*(K**2)*BK2I H0I=H0I+(0.5d0*A12-0.5d0*A13)*(K**2)*BK2JI*N*(N+1) C PRINT*,' H0I= ',H0 H0I=H0I+AK5I*K**2*(-0.5d0*A7+0.5d0*A1) c if(N.EQ.2) print*,'A7=',A7,'A1=',A1,'H0I=',H0I c 1,'K=',K,'dans la fontion' H0I=H0I+AK5KI*K**4*(-0.5d0*A7+0.5d0*A1) H0I=H0I+AK5JI*K**2*(-0.5d0*A7+0.5d0*A1)*N*(N+1) c ik debug march02: erreur in AK7I,"A2" and the signs. c H0I=H0I+AK7I*(-0.5*A10+0.5*A11+A2+0.5*A16-0.5*A17) H0I=H0I+AK7I*(+0.5d0*A10-0.5d0*A11-0.5d0*A16+0.5d0*A17) c if(N.EQ.1.and.isig.eq.0) print*,'H0I=',H0I,'AK7I=',AK7I c H0I=H0I+AK9*(-0.5*A10B+0.5*A11B+0.5*A16B-0.5*A17B) H0I=H0I+AK7KI*(+0.5d0*A10-0.5d0*A11-0.5d0*A16+0.5d0*A17)*K**2 H0I=H0I+AK7JI*(+0.5d0*A10-0.5d0*A11-0.5d0*A16+0.5d0*A17)*N*(N+1) c attention:sin3gamma=exp(ik3g-expik(-3g))/2i --->facteur -1 C PRINT*,' AK7=',AK7,' A1=',A1,'RHOKSIG=',RHOKSIG,'RHOKK=', C 1RHOKK,'N=',N,'K=',K,'IVTOR=',IVTOR C PRINT*,' CONV = ',CONV C H0 = H0/CONV c 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*834 CHARACTER*1 PR,PROBS CHARACTER*6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1 1,NN=(30)+1,ISIGMA=(2)) 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,20000),REF(20000) COMMON/SYMB/ABC COMMON/QUANT/ISIG,IV,N,KK,IISIG DIMENSION CST(2,139),ETOR(KDMX,9) complex(8) A(9,NTORMX,2*KDMX,NN,ISIGMA) complex(8) COEFA,COEFA1,COEFAA,COFAA1,COEFA2,COEFA3,COEFA4 complex(8) COFAA12,COEFA12 complex(8) H1 complex(8) A1,A2,A3,A3B,A4,A4B,A5,A6 RHO=CST(LO,128) F=CST(LO,127) V3=CST(LO,129) V6=CST(LO,130) V9=CST(LO,131) V12=CST(LO,132) RHORHO=CST(LO,134) ODAB=CST(LO,28) ODABJ=CST(LO,98) DAC=CST(LO,44) DACJ=CST(LO,96) DAC12=CST(LO,94) ODAB6=CST(LO,58) IK=K+N +1 ISIGN=1 IF (KP.EQ.(K-1)) ISIGN=-1 A1=0.d0 A2=0.d0 A3=0.d0 A4=0.d0 A5=0.d0 A6=0.d0 A3B=0.d0 A4B=0.d0 NP1=N+1 DO 10 II=1,NDIMTO COEFA=dCONJG(A(IVTOR,II,IK,NP1,IISIG)) COEFA1=A(IVTORP,II,IK+ISIGN,NP1,IISIG) IF (II.EQ.NDIMTO ) THEN COEFAA=0.d0 COFAA1 =0.d0 ELSE COEFAA=A(IVTOR,II+1,IK,NP1,IISIG) COFAA1 =A(IVTORP,II+1,IK+ISIGN,NP1,IISIG) ENDIF IF(II.GT.(NDIMTO-2)) THEN COEFA3=0.d0 COEFA4=0.d0 ELSE COEFA3=A(IVTOR,II+2,IK,NP1,IISIG) COEFA4=A(IVTORP,II+2,IK+ISIGN,NP1,IISIG) ENDIF IF(II.EQ.1) THEN COEFA2 =0.d0 ELSE COEFA2 =A(IVTORP,II-1,IK+ISIGN,NP1,IISIG) 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.d0 ELSE C COFAA12=A(IVTORP,II+4,IK+ISIGN,NP1,IISIG) COFAA12=A(IVTORP,II+3,IK+ISIGN,NP1,IISIG) ENDIF C IF(II.LE.4) THEN IF(II.LE.3) THEN COEFA12=0.d0 ELSE C COEFA12=A(IVTORP,II-4,IK+ISIGN,NP1,IISIG) COEFA12=A(IVTORP,II-3,IK+ISIGN,NP1,IISIG) ENDIF A1=A1+COEFA*COEFA1 A2=A2+dCONJG(COEFAA)*COEFA1 A3=A3+COEFA*COFAA1 A3B=A3B+COEFA*COFAA12 A4=A4+COEFA*COEFA2 A4B=A4B+COEFA*COEFA12 A5=A5+dCONJG(COEFA1)*COEFA3 A6=A6+COEFA*COEFA4 10 CONTINUE C PRINT*,' A1= ',A1,' A2= ',A2,' A3= ',A3 NN1=N*(N+1)-K*(K+ISIGN) ANN=dFLOAT(NN1) H1=ODAB*dSQRT(ANN)*(K+0.5d0*ISIGN) H1=H1+ODABJ*dSQRT(ANN)*(K+0.5d0*ISIGN)*(N*(N+1)) H1=H1*(A1-0.5d0*(A2+A3)) c if(N.EQ.2) print*,'A1=',A1,'A2=',A2,'A3=',A3,'H1=',H1 H1=H1+ODAB6*dSQRT(ANN)*(K+0.5d0*ISIGN)*(A1-0.5d0*(A5+A6)) H1=H1+(-ISIGN)*(DAC/2.d0)*dSQRT(ANN)*(K+0.5d0*ISIGN)*(A4-A3) H1=H1+(-ISIGN)*(DACJ/2.d0)*dSQRT(ANN)*(K+0.5d0*ISIGN)*(A4-A3) 1*(N*(N+1)) H1=H1+(-ISIGN)*(DAC12/2.d0)*dSQRT(ANN)*(K+0.5d0*ISIGN)* 1(A4B-A3B) C H1 = H1/CONV RETURN END C*********************************************************** FUNCTION H1I(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*834 CHARACTER*1 PR,PROBS CHARACTER*6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1 1,NN=(30)+1,ISIGMA=(2)) 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,20000),REF(20000) COMMON/SYMB/ABC COMMON/QUANT/ISIG,IV,N,KK,IISIG DIMENSION CST(2,139),ETOR(KDMX,9) complex(8) A(9,NTORMX,2*KDMX,NN,ISIGMA) complex(8) COEFA,COEFA1,COEFAA,COFAA1,COEFA2,COEFA3,COEFA4 complex(8) COFAA12,COEFA12 complex(8) H1I complex(8) A1,A2,A3,A3B,A4,A4B,A5,A6 DACI=CST(LO,101) DACJI=CST(LO,102) ODACI=CST(LO,103) ODABI=CST(LO,122) ODABJI=CST(LO,123) ODAB6I=CST(LO,123) IK=K+N +1 ISIGN=1 IF (KP.EQ.(K-1)) ISIGN=-1 A1=0.d0 A2=0.d0 A3=0.d0 A4=0.d0 A5=0.d0 A6=0.d0 A3B=0.d0 A4B=0.d0 NP1=N+1 DO 10 II=1,NDIMTO COEFA=dCONJG(A(IVTOR,II,IK,NP1,IISIG)) COEFA1=A(IVTORP,II,IK+ISIGN,NP1,IISIG) IF (II.EQ.NDIMTO ) THEN COEFAA=0.d0 COFAA1 =0.d0 ELSE COEFAA=A(IVTOR,II+1,IK,NP1,IISIG) COFAA1 =A(IVTORP,II+1,IK+ISIGN,NP1,IISIG) ENDIF IF(II.GT.(NDIMTO-2)) THEN COEFA3=0.d0 COEFA4=0.d0 ELSE COEFA3=A(IVTOR,II+2,IK,NP1,IISIG) COEFA4=A(IVTORP,II+2,IK+ISIGN,NP1,IISIG) ENDIF IF(II.EQ.1) THEN COEFA2 =0.d0 ELSE COEFA2 =A(IVTORP,II-1,IK+ISIGN,NP1,IISIG) 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.d0 ELSE C COFAA12=A(IVTORP,II+4,IK+ISIGN,NP1,IISIG) COFAA12=A(IVTORP,II+3,IK+ISIGN,NP1,IISIG) ENDIF C IF(II.LE.4) THEN IF(II.LE.3) THEN COEFA12=0.d0 ELSE C COEFA12=A(IVTORP,II-4,IK+ISIGN,NP1,IISIG) COEFA12=A(IVTORP,II-3,IK+ISIGN,NP1,IISIG) ENDIF A1=A1+COEFA*COEFA1 A2=A2+dCONJG(COEFAA)*COEFA1 A3=A3+COEFA*COFAA1 A3B=A3B+COEFA*COFAA12 A4=A4+COEFA*COEFA2 A4B=A4B+COEFA*COEFA12 A5=A5+dCONJG(COEFA1)*COEFA3 A6=A6+COEFA*COEFA4 10 CONTINUE C PRINT*,' A1= ',A1,' A2= ',A2,' A3= ',A3 NN1=N*(N+1)-K*(K+ISIGN) ANN=dFLOAT(NN1) c JaJc+JcJa(1-cos3gamma)=1/2i(PzP+-P+Pz): le facteur 2K+1 est devenu c 2(K+0.5) et le facteur 2 disparait. H1I=(-ISIGN)*(DACI)*dSQRT(ANN)*(K+0.5d0*ISIGN)*A1 c if(N.EQ.2) print*,'DACI=',DACI,'A1=',A1,'ANN=',ANN,'K=',K c 1,'H1I=',H1I,'isign=',isign H1I=H1I+(-ISIGN)*(ODACI)*dSQRT(ANN)*(K+0.5d0*ISIGN) &*(A1-0.5d0*(A2+A3)) c H1I=H1I+(-ISIGN)*(DAC/2.0)*SQRT(ANN)*(K+0.5*ISIGN)*(A4-A3) H1I=H1I+(-ISIGN)*(DACJI)*dSQRT(ANN)*(K+0.5d0*ISIGN) 1*(N*(N+1))*A1 c attention, for odab we are taking the sin3gamma term H1I=H1I+ODABI*dSQRT(ANN)*(K+0.5d0*ISIGN)*(0.5d0*(A3-A2)) c if(N.EQ.2) print*,'ODABI=',ODABI,'A2=',A2,'A3=',A3, c 1'H1I=',H1I H1I=H1I+ODABJI*dSQRT(ANN)*(K+0.5d0*ISIGN)*(N*(N+1))*(0.5d0*(A3-A2)) H1I=H1I+ODAB6I*dSQRT(ANN)*(K+0.5d0*ISIGN)*(0.5d0*(A6-A5)) C H1 = H1/CONV c print*,'H1I=',H1I 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*834 CHARACTER*1 PR,PROBS CHARACTER*6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1 1,NN=(30)+1,ISIGMA=(2)) COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRON1 , * IBGTME,IBGVTD ,EVIB(2),IRMW,TERM COMMON/CHARA/PARA(2,160),PR,PROBS(2,20000),REF(20000) COMMON/ROTOR/NROTOR,NDIMTO COMMON/SYMB/ABC COMMON/QUANT/ISIG,IV,N,KK,IISIG DIMENSION CST(2,139),ETOR(KDMX,9) complex(8) A(9,NTORMX,2*KDMX,NN,ISIGMA) complex(8) COEFA,COEFA1 complex(8) H2 complex(8) A1,A2,A2B,A3,A3B,A4 DAB=CST(LO,27) DABJ=CST(LO,29) DABK=CST(LO,30) ODELTA=CST(LO,47) DELTA=CST(LO,48) DELTAB=CST(LO,65) ODELTB=CST(LO,66) ESPOIR=CST(LO,90) C RHOJ=CST(LO,60) C RHOK=CST(LO,61) RHO=CST(LO,128) F=CST(LO,127) V3=CST(LO,129) V6=CST(LO,130) V9=CST(LO,131) V12=CST(LO,132) RHORHO=CST(LO,134) IK=K+N +1 ISIGN=1 IF (KP.EQ.(K-1)) ISIGN=-1 A1=0.d0 A2=0.d0 A3=0.d0 A2B=0.d0 A3B=0.d0 A4=0.d0 NP1=N+1 DO 11 II=1,NDIMTO KL=II-KTRON1 COEFA=dCONJG(A(IVTOR,II,IK,NP1,IISIG)) COEFA1=A(IVTORP,II,IK+ISIGN,NP1,IISIG) C RHOEFF=RHO+RHOJ*N*(N+1)+RHOK*K**2 RHOEFF=RHO RHOKSG =(3.d0*KL+ISIG+RHOEFF*(K+ISIGN))*((K+ISIGN)**2) RHOKSH =(3.d0*KL+ISIG+RHOEFF*(K+ISIGN))**3*((K+ISIGN)**2) RHOKS2 =(3.d0*KL+ISIG+RHOEFF*K)*(K**2) RHOKSI =(3.d0*KL+ISIG+RHOEFF*K)**3*(K**2) RHOKS3 =3.d0*KL+ISIG+RHOEFF*K RHOKS4 =3.d0*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 NN1=N*(N+1)-K*(K+ISIGN) ANN=dFLOAT(NN1) 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*dSQRT(ANN)*(K+0.5d0*ISIGN)*A1 * +DABJ*dSQRT(ANN)*(K+0.5d0*ISIGN)*A1*N*(N+1) * +DABK*dSQRT(ANN)*0.5d0*(K**3+(K+1.d0*ISIGN)**3)*A1 H2=H2+ODELTA*A2*dSQRT(ANN)*0.5d0 H2=H2+ODELTB*A2B*dSQRT(ANN)*0.5d0 H2=H2+DELTA*A3*dSQRT(ANN)*0.5d0 H2=H2+DELTAB*A3B*dSQRT(ANN)*0.5d0 H2=H2+ESPOIR*A4*dSQRT(ANN)*0.5d0 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*834 CHARACTER*1 PR,PROBS CHARACTER*6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1 1,NN=(30)+1,ISIGMA=(2)) COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRON1 , * IBGTME,IBGVTD ,EVIB(2),IRMW,TERM COMMON/CHARA/PARA(2,160),PR,PROBS(2,20000),REF(20000) COMMON/ROTOR/NROTOR,NDIMTO COMMON/SYMB/ABC COMMON/QUANT/ISIG,IV,N,KK,IISIG DIMENSION CST(2,139),ETOR(KDMX,9) complex(8) A(9,NTORMX,2*KDMX,NN,ISIGMA) complex(8) COEFA,COEFA2,COEFA1,COFAA2,COEFA3,COEFA12 complex(8) COEFA4,COEFAA4,COFAA12 complex(8) A1,A2,A3,A4,A4B,A5,A6,A6B,A7 complex(8) H3 complex(8) A8,A9,A10,A11 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) HLKJ=CST(LO,35) C RHOJ=CST(LO,60) RHO=CST(LO,128) F=CST(LO,127) V3=CST(LO,129) V6=CST(LO,130) V9=CST(LO,131) V12=CST(LO,132) RHORHO=CST(LO,134) 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.d0 A2=0.d0 A3=0.d0 A4=0.d0 A5=0.d0 A6=0.d0 A7=0.d0 A8=0.d0 A9=0.d0 A10=0.d0 A11=0.d0 A4B=0.d0 A6B=0.d0 NP1=N+1 DO 12 II=1,NDIMTO KL=II-KTRON1 COEFA=dCONJG(A(IVTOR,II,IK,NP1,IISIG)) COEFA2=A(IVTORP,II,IK+ISIGN,NP1,IISIG) IF (II.EQ.NDIMTO ) THEN COEFA1=0.d0 COFAA2 =0.d0 ELSE COEFA1=A(IVTOR,II+1,IK,NP1,IISIG) COFAA2 =A(IVTORP,II+1,IK+ISIGN,NP1,IISIG) ENDIF IF(II.EQ.1) THEN COEFA3 =0.d0 ELSE COEFA3 =A(IVTORP,II-1,IK+ISIGN,NP1,IISIG) ENDIF CC IF(II.LE.4) THEN IF(II.LE.3) THEN COEFA12=0.d0 ELSE C COEFA12=A(IVTORP,II-4,IK+ISIGN,NP1,IISIG) COEFA12=A(IVTORP,II-3,IK+ISIGN,NP1,IISIG) ENDIF IF(II.GT.(NDIMTO-2)) THEN COEFA4=0.0 COEFAA4=0.d0 ELSE COEFA4=A(IVTOR,II+2,IK,NP1,IISIG) COEFAA4=A(IVTORP,II+2,IK+ISIGN,NP1,IISIG) ENDIF C IF(II.GT.(NDIMTO-4)) THEN IF(II.GT.(NDIMTO-3)) THEN COFAA12=0.d0 ELSE C COFAA12=A(IVTORP,II+4,IK+ISIGN,NP1,IISIG) COFAA12=A(IVTORP,II+3,IK+ISIGN,NP1,IISIG) ENDIF C RHOEFF=RHO+RHOJ*N*(N+1)+RHOK*K**2 RHOEFF=RHO RHOKSG =3.d0*KL+ISIG+RHOEFF*K RHOKS2 =(3.d0*KL+ISIG+RHOEFF*(K+ISIGN))*(K+ISIGN) RHOKS3 =(3.d0*KL+ISIG+RHOEFF*K)*(K) RHOK2=3.d0*KL+ISIG+RHOEFF*(K+ISIGN) RHOKS4=(3.d0*KL+ISIG+RHOEFF*K)**3 RHOKS4=RHOKS4*K RHOKS5=(3.d0*KL+ISIG+RHOEFF*(K+ISIGN))**3 RHOKS5=RHOKS5*(K+ISIGN) RHOKS6=(3.d0*KL+ISIG+RHOEFF*K)*(K) RHOKS6=RHOKS6*(K+ISIGN)**2 RHOKS7=(3.d0*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+dCONJG(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+dCONJG(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.d0-ODELN*N*(N+1)-0.5d0*ODELK*(K**2+(K+ISIGN)**2)+ * OHJ*(N*(N+1))**2+0.5d0*OHJK*N*(N+1)*(K**2+(K+ISIGN)**2) * +0.5d0*OHK*(K**4+(K+ISIGN)**4) H3=A1*H3 H3=H3+0.5d0*C1*A2 H3=H3+0.5d0*C1J*A2*N*(N+1) C PRINT*,' H3= ',H3 H3=H3+0.5d0*C2*(A1-0.5d0*(A3+A4)) c if(N.EQ.2) print*,'A1=',A1,'A3=',A3,'A4=',A4 c 1,'H3=',H3,'B=',B,'C=',C H3=H3+0.5d0*C2J*(A1-0.5d0*(A3+A4))*(N*(N+1)) H3=H3+0.5d0*C3*A5 H3=H3+0.5d0*C3J*A5*N*(N+1) H3=H3+0.5d0*C4*A7 H3=H3+0.5d0*C12*A10 H3=H3+0.5d0*C12J*A10*N*(N+1) H3=H3+0.5d0*C4J*A7*N*(N+1) C IF(N.EQ.1) PRINT*,'H3=',H3 H3=H3+0.5d0*C1K*(K**2+(K+ISIGN)**2)*A2 H3=H3+0.5d0*C2K*(A1-0.5d0*(A3+A4))*(K**2+(K+ISIGN)**2) H3=H3+0.5d0*C4K*A11 H3=H3+0.5d0*C11*(A1-0.5d0*(A8+A9)) ANN=N*(N+1)-K*(K+0.5d0*ISIGN) ALL=N*(N+1)-(K+0.5d0*ISIGN)*(K+ISIGN) H3=H3*dSQRT(ANN*ALL) c if(N.EQ.2) print*,'ANN=',ANN,'ALL=',ALL,'H3 =',H3 C PRINT*,' H3= ',H3 H3=H3+((A6-A4)*(-ISIGN)*0.5d0*DBC*(1.d0/4.d0))*(dSQRT(ANN*ALL)) H3=H3+((A6-A4)*(-ISIGN)*0.5d0*DBCJ*(1.d0/4.d0))*(dSQRT(ANN*ALL)) 1*(N*(N+1)) H3=H3+((A6B-A4B)*(-ISIGN)*0.5d0*DBC12*(1.d0/4.d0))*(dSQRT(ANN*ALL)) RETURN END C************************************************************** FUNCTION H3I(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*834 CHARACTER*1 PR,PROBS CHARACTER*6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1 1,NN=(30)+1,ISIGMA=(2)) COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRON1 , * IBGTME,IBGVTD ,EVIB(2),IRMW,TERM COMMON/CHARA/PARA(2,160),PR,PROBS(2,20000),REF(20000) COMMON/ROTOR/NROTOR,NDIMTO COMMON/SYMB/ABC COMMON/QUANT/ISIG,IV,N,KK,IISIG DIMENSION CST(2,139),ETOR(KDMX,9) complex(8) A(9,NTORMX,2*KDMX,NN,ISIGMA) complex(8) COEFA,COEFA2,COEFA1,COFAA2,COEFA3,COEFA12 complex(8) COEFA4,COEFAA4,COFAA12 complex(8) A1,A2,A3,A4,A4B,A5,A6,A6B,A7 complex(8) H3I complex(8) A8,A9,A10,A11 DBC=CST(LO,45) DBCJ=CST(LO,97) DBC12=CST(LO,95) C2I=CST(LO,118) C2JI=CST(LO,119) C2KI=CST(LO,120) C11I=CST(LO,121) DBCI=CST(LO,125) ODBCI=CST(LO,126) 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.d0 A2=0.d0 A3=0.d0 A4=0.d0 A5=0.d0 A6=0.d0 A7=0.d0 A8=0.d0 A9=0.d0 A10=0.d0 A11=0.d0 A4B=0.d0 A6B=0.d0 NP1=N+1 DO 12 II=1,NDIMTO KL=II-KTRON1 COEFA=dCONJG(A(IVTOR,II,IK,NP1,IISIG)) COEFA2=A(IVTORP,II,IK+ISIGN,NP1,IISIG) IF (II.EQ.NDIMTO ) THEN COEFA1=0.d0 COFAA2 =0.d0 ELSE COEFA1=A(IVTOR,II+1,IK,NP1,IISIG) COFAA2 =A(IVTORP,II+1,IK+ISIGN,NP1,IISIG) ENDIF IF(II.EQ.1) THEN COEFA3 =0.d0 ELSE COEFA3 =A(IVTORP,II-1,IK+ISIGN,NP1,IISIG) ENDIF CC IF(II.LE.4) THEN IF(II.LE.3) THEN COEFA12=0.d0 ELSE C COEFA12=A(IVTORP,II-4,IK+ISIGN,NP1,IISIG) COEFA12=A(IVTORP,II-3,IK+ISIGN,NP1,IISIG) ENDIF IF(II.GT.(NDIMTO-2)) THEN COEFA4=0.d0 COEFAA4=0.d0 ELSE COEFA4=A(IVTOR,II+2,IK,NP1,IISIG) COEFAA4=A(IVTORP,II+2,IK+ISIGN,NP1,IISIG) ENDIF C IF(II.GT.(NDIMTO-4)) THEN IF(II.GT.(NDIMTO-3)) THEN COFAA12=0.d0 ELSE C COFAA12=A(IVTORP,II+4,IK+ISIGN) COFAA12=A(IVTORP,II+3,IK+ISIGN,NP1,IISIG) ENDIF C RHOEFF=RHO+RHOJ*N*(N+1)+RHOK*K**2 RHO=CST(LO,128) RHOEFF=RHO RHOKSG =3.d0*KL+ISIG+RHOEFF*K RHOKS2 =(3.d0*KL+ISIG+RHOEFF*(K+ISIGN))*(K+ISIGN) RHOKS3 =(3.d0*KL+ISIG+RHOEFF*K)*(K) RHOK2=3.d0*KL+ISIG+RHOEFF*(K+ISIGN) RHOKS4=(3.d0*KL+ISIG+RHOEFF*K)**3 RHOKS4=RHOKS4*K RHOKS5=(3.d0*KL+ISIG+RHOEFF*(K+ISIGN))**3 RHOKS5=RHOKS5*(K+ISIGN) RHOKS6=(3.d0*KL+ISIG+RHOEFF*K)*(K) RHOKS6=RHOKS6*(K+ISIGN)**2 RHOKS7=(3.d0*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+dCONJG(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+dCONJG(COEFA2)*COEFA4 A9=A9+COEFA*COEFAA4 A10=A10+COEFA*COEFA2*(RHOKS4+RHOKS5) A11=A11+COEFA*COEFA2*(RHOKS6+RHOKS7) 12 CONTINUE c H3I=0.5*C2I*(0.5*(A4-A3)) H3I=0.5d0*C2I*(0.5d0*(A4-A6)) c if(N.EQ.2) print*,'C2I=',C2I,'A4=',A4,'A3=',A3 c 1,'A6=',A6,'H3I=',H3I c H3I=H3I+0.5*C2JI*(0.5*(A4-A3))*(N*(N+1)) H3I=H3I+0.5d0*C2JI*(0.5d0*(A4-A6))*(N*(N+1)) c H3I=H3I+0.5*C2KI*(0.5*(A4-A3))*(K**2+(K+ISIGN)**2) H3I=H3I+0.5d0*C2KI*(0.5d0*(A4-A6))*(K**2+(K+ISIGN)**2) H3I=H3I+0.5d0*C11I*(0.5d0*(A9-A8)) ANN=N*(N+1)-K*(K+0.5d0*ISIGN) ALL=N*(N+1)-(K+0.5d0*ISIGN)*(K+ISIGN) H3I=H3I*dSQRT(ANN*ALL) c if(N.EQ.2) print*,'ANN=',ANN,'ALL=',ALL,'H3I=',H3I c H3I=H3I+(A1-0.5*(A6+A4)*(-ISIGN)*0.5*DBC*(1./1.))*(SQRT(ANN*ALL)) cik attention isign=2 or -2 H3I=H3I+(A1*(-ISIGN)*0.25d0*DBCI)*(dSQRT(ANN*ALL)) H3I=H3I+((-ISIGN)*0.25d0*ODBCI*dSQRT(ANN*ALL)) 1*(A1-0.5d0*(A4+A6)) cik debug: A3+A6 c 1*(A1-0.5*(A3+A4)) c H3I=H3I+(A1*(-ISIGN)*0.5*DBCJI*(1./1.)) c 1*(SQRT(ANN*ALL)) c 2*(N*(N+1)) 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*834 CHARACTER*1 PR,PROBS CHARACTER*6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1 1,NN=(30)+1,ISIGMA=(2)) COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRON1 , * IBGTME,IBGVTD ,EVIB(2),IRMW,TERM COMMON/CHARA/PARA(2,160),PR,PROBS(2,20000),REF(20000) COMMON/ROTOR/NROTOR,NDIMTO COMMON/SYMB/ABC COMMON/QUANT/ISIG,IV,N,KK,IISIG DIMENSION CST(2,139),ETOR(KDMX,9) complex(8) A(9,NTORMX,2*KDMX,NN,ISIGMA) complex(8) COEFA,COEFAA complex(8) H4,A1 RHO=CST(LO,128) F=CST(LO,127) V3=CST(LO,129) V6=CST(LO,130) V9=CST(LO,131) V12=CST(LO,132) RHORHO=CST(LO,134) OLV=CST(LO,31) IK=K+N +1 NP1=N+1 A1=0.d0 DO 25 II=1,NDIMTO KL=II-KTRON1 COEFA=dCONJG(A(IVTOR,II,IK,NP1,IISIG)) COEFAA=A(IVTORP,II,IK,NP1,IISIG) C RHOEFF=RHO+RHOJ*N*(N+1)+RHOK*K**2 RHOEFF=RHO RHOKSG =3.d0*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*834 CHARACTER*1 PR,PROBS CHARACTER*6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1 1,NN=(30)+1,ISIGMA=(2)) COMMON/EIGEN/HR(NDMX,NDMX),HI(NDMX,NDMX),WORK(NDMX), *EGVC3R(KDMX,9),EGVC3I(KDMX,9),NBR(2),VECTPR(10,961,KDMX,9) *,VECTPI(10,961,KDMX,9) 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,IISIG COMMON/CHARA/PARA(2,160),PR,PROBS(2,20000),REF(20000) DIMENSION CST(2,139),ETOR(KDMX,9) complex(8) A(9,NTORMX,2*KDMX,NN,ISIGMA) complex(8) H0I,H0,H1,H1I,H2,H3,H3I,H4,HR2(NDMX,NDMX) complex(8) HI2(NDMX,NDMX) DO 3 I=1,NROTOR DO 4 J=1,I C INITIALISATION HR2(I,J)=(0.d0,0.d0) HI2(I,J)=(0.d0,0.d0) 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 HR2(I,J)=H0(K,IVTOR,KP,IVTORP,CST,LO,ETOR,A) 1 + H4(K,IVTOR,KP,IVTORP,CST,LO,ETOR,A) HI2(I,J)=H0I(K,IVTOR,KP,IVTORP,CST,LO,ETOR,A) 1*(0.,1) c if(N.EQ.2) print*,'HI=',HI(I,J),'I=',I,'J=',J c 1,'H0I=',H0I(K,IVTOR,KP,IVTORP,CST,LO,ETOR,A) c 2,'K=',K,'HI2=',HI2(I,J),'HR2=',HR2(I,J) c HI(I,J)=0.0 ELSE IF (IABS(K-KP).EQ.1) THEN IF (IABS(IVTOR-IVTORP).LT.9) THEN HR2(I,J)= H2(K,IVTOR,KP,IVTORP,CST,LO,ETOR,A) 1+ H1(K,IVTOR,KP,IVTORP,CST,LO,ETOR,A) HI2(I,J)=H1I(K,IVTOR,KP,IVTORP,CST,LO,ETOR,A) 1*(0.,1) c if(N.EQ.2) print*,'HR2=',HR2(I,J),'HI2=',HI2(I,J) c 1,'H2 =',H2(K,IVTOR,KP,IVTORP,CST,LO,ETOR,A) c 2,'H1 =',H1(K,IVTOR,KP,IVTORP,CST,LO,ETOR,A) c 3,'H1I =',H1I(K,IVTOR,KP,IVTORP,CST,LO,ETOR,A) c HI(I,J)=0.0 ENDIF ELSE IF(IABS(K-KP).EQ.2) THEN IF (IABS(IVTOR-IVTORP).LT.9) THEN HR2(I,J)= H3(K,IVTOR,KP,IVTORP,CST,LO,ETOR,A) HI2(I,J)= H3I(K,IVTOR,KP,IVTORP,CST,LO,ETOR,A) 1*(0.,1) c if(N.EQ.2) print*,'HR2=',HR2(I,J),'HI2=',HI2(I,J) c 1,'H3 =',H3(K,IVTOR,KP,IVTORP,CST,LO,ETOR,A) c 1,'H3I=',H3I(K,IVTOR,KP,IVTORP,CST,LO,ETOR,A) ENDIF ENDIF HR(I,J)=dREAL(HR2(I,J)+HI2(I,J)) HI(I,J)=dIMAG(HR2(I,J)+HI2(I,J)) 8 CONTINUE 7 CONTINUE DO 20 I=2,NROTOR DO 21 J=1,I-1 HR(J,I)=HR(I,J) HI(J,I)=-(HI(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*834 CHARACTER*1 PR,PROBS CHARACTER*6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1 1,NN=(30)+1,ISIGMA=(2)) COMMON/EIGEN/HR(NDMX,NDMX),HI(NDMX,NDMX),WORK(NDMX), *EGVC3R(KDMX,9),EGVC3I(KDMX,9),NBR(2),VECTPR(10,961,KDMX,9) *,VECTPI(10,961,KDMX,9) COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRON1 , * IBGTME,IBGVTD ,EVIB(2),IRMW,TERM COMMON/SYMB/ABC COMMON/QUANT/ISIG,IV,N,KK,IISIG COMMON/ROTOR/NROTOR,NDIMTO COMMON/CHARA/PARA(2,160),PR,PROBS(2,20000),REF(20000) DIMENSION CST(2,139) C C LOOP ON THE BASIS FUNCTIONS RHO=CST(LO,128) F=CST(LO,127) V3=CST(LO,129) V3I=CST(LO,133) V6=CST(LO,130) V9=CST(LO,131) V12=CST(LO,132) RHORHO=CST(LO,134) C INITIALISATION DO 3 I=1,NDIMTO DO 4 J=1,I HR(I,J)=0.d0 HI(I,J)=0.d0 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 if(V3I.NE.0) then a0=-90. else a0=0. endif c=3.d0*ktor+isig cp=3.d0*ktorp+isig cc=dcosd(c*a0) ss=dsind(c*a0) ccp=dcosd(cp*a0) ssp=dsind(cp*a0) C RHOEFF=RHORHO+RHOJ*N*(N+1)+RHOK*K**2 RHOEFF=RHORHO C C KTOR=KTORP c V0=V3I c V0=0.2*V3 V0=0.d0 C C PRINT*,' KTOR= ',KTOR,' KTORP= ',KTORP IF (KTOR.EQ.KTORP) THEN c HR(I,J) = F*(3.*KTOR+ISIG+RHOEFF*K)**2+V3/2. c & +V6/2.+V9/2.+V12/2.+V0/2. cdebugik, 2Frho.pa.pg sign changed! HR(I,J) = F*(3.d0*KTOR+ISIG-RHOEFF*K)**2+V3/2.d0 & +V6/2.d0+V9/2.d0+V12/2.d0+V0/2.d0 c if(N.EQ.1) print*,'HR=',HR(I,J),'I=',I,'J=',J c 1,'isig=',isig,'F=',F,'KTOR=',KTOR,'RHOEFF=',RHOEFF,'K=',K, c 2'V3=',V3,'V6=',V6,'V9=',V9,'V0=',V0,'V12=',V12 ELSE IF(IABS(KTOR-KTORP).EQ.1) THEN C C KTOR=KTORP+1 OR KTOR=KTORP-1 C HR(I,J) = -V3/4.d0 c only k'=k-1 is programmed (the loop on J stops at J=I) HI(I,J)=-V3I/4.d0 ELSE IF (IABS(KTOR-KTORP).EQ.2) THEN C C KTOR=KTORP+2 OR KTOR=KTORP-2 C HR(I,J) = -V6/4.d0 ELSE IF(IABS(KTOR-KTORP).EQ.3) THEN HR(I,J)=-V9/4.d0 ELSE IF(IABS(KTOR-KTORP).EQ.4) THEN HR(I,J)=-V12/4.d0 ENDIF HR(I,J)=HR(I,J) HI(I,J)=HI(I,J) 11 CONTINUE 10 CONTINUE C SYMETRISES THE MATRIX DO 5 I=2,NDIMTO DO 6 J=1,I-1 HR(J,I) = HR(I,J) HI(J,I) =-HI(I,J) 6 CONTINUE 5 CONTINUE RETURN END SUBROUTINE PARITY(A,EGVC4R,EGVC4I,II) 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 1,NN=(30)+1,ISIGMA=(2)) 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/HR(NDMX,NDMX),HI(NDMX,NDMX),WORK(NDMX), *EGVC3R(KDMX,9),EGVC3I(KDMX,9),NBR(2),VECTPR(10,961,KDMX,9) *,VECTPI(10,961,KDMX,9) COMMON/QUANT/ISIG,IV,N,KK,IISIG COMMON/CHARA/PARA(2,160),PR,PROBS(2,20000),REF(20000) complex(8) A(9,NTORMX,2*KDMX,NN,ISIGMA) DIMENSION EGVC4R(KDMX,NTORMX,NDMX) DIMENSION EGVC4I(KDMX,NTORMX,NDMX) complex(8) YCONJ,Y,PERC2L,PER23L,A2LO,A3LO complex(8) COEFAL,COEFAAL 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.,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 NP1=N+1 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=dconjg(A(IVTORP,III,ILOW,NP1,IISIG)) COEFAAL=A(IVTOR1,III,IOPPLO,NP1,IISIG) IF(ISIG.EQ.0) THEN COEF4L=A(IVTOR1,IIIOPP,IOPPLO,NP1,IISIG) ELSE COEF4L=0.0 ENDIF A2LO=A2LO+COEFAL*COEFAAL A3LO=A3LO+COEFAL*COEF4L 298 CONTINUE YCONJ=dcmplx(EGVC4R(ILOW,IVTORP,II), 1-EGVC4I(ILOW,IVTORP,II)) Y=dcmplx(EGVC4R(IOPPLO,IVTOR1,II), 1EGVC4I(IOPPLO,IVTOR1,II)) PERC2L=PERC2L+A2LO*EXPPLO*YCONJ*Y c 1 EGVC4(ILOW,IVTORP,II)*EGVC4(IOPPLO,IVTOR1,II) PER23L(II)=PER23L(II)+A3LO*EXPPLO*YCONJ*Y c 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************************************************************* 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*834 COMMON/SYMB/ABC DO 1 K=1,(139) 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,AINCER) 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*834 CHARACTER MUABC*6 CHARACTER*6 PARA,REF CHARACTER*1 AST CHARACTER*1 PR,PROBS PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1 1,NN=(30)+1,ISIGMA=(2)) COMMON/EIGEN/HR(NDMX,NDMX),HI(NDMX,NDMX),WORK(NDMX), *EGVC3R(KDMX,9),EGVC3I(KDMX,9),NBR(2),VECTPR(10,961,KDMX,9) *,VECTPI(10,961,KDMX,9) COMMON/EIGEN1/EGVL(2*NDMX),EGVC(NDMX,2*NDMX) *,EGVCR(NDMX,2*NDMX),EGVCI(NDMX,2*NDMX) COMMON/TOR/A(9,NTORMX,2*KDMX,NN,ISIGMA),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/DERIVR(10,961,80),ENER(10,961),DERIVI(10,961,80) COMMON/EXPDAT / ETRANS(20000),IVOBS(2,20000), * NOBS(2,20000),KOBS(2,20000),IBLK(2,20000),IW(20000),W(20000), * NDATA,NADAT,EPSI,NOFIT,NFITMW,NFITIR,NFIMW0 ,NFIMW1 ,NITT, * IAST(20000),NFI004 ,NFI080 ,NFI100 ,NFI020 ,NFI200 ,NFI045 , & NGST0 ,NFI010 ,SW070,NFI070 ,NFIMW2,IKAKC,JMAX,NFI1M0, & NFIR10,NFIR21,NFIR32,NFIMW3,NFIMW4,SWA,SWE,NFITMWA,NFITMWE &,INT COMMON/SYMB/ABC COMMON/QUANT/ISIG,IV,N,KK,IISIG COMMON/CHARA/PARA(2,160),PR,PROBS(2,20000),REF(20000) COMMON/INT/TPR,BLTZ,CONV2,SSQ,BLTZ2 DIMENSION CST(2,139),IBLSTO(2),EE(2),KC(2,20000) DIMENSION IVV(2),INK(2),ICTT(6),INKF(2),AINCER(20000) complex(8) A S=0. SMW=0. SMW0=0.0 SMW1=0.0 SMW2=0.0 SMW3=0.0 SMW4=0.0 SWA=0.0 SWE=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(LO)=IV+6 INK(LO)=N**2+N+KK+1 INKF(1)=INK(1) ELSE ISIG=0 IVV(LO)=IV+1 INK(LO)=N**2+N+KK+1-IPR*N ENDIF EE(LO)=ENER(IVV(LO),INK(LO)) if(N.EQ.0.AND.IV.EQ.0.AND.ISIG.EQ.0) E0=EE(1) 31 CONTINUE IISIG=ISIG+1 ECALC=TERM+EE(2)-EE(1) C C Calculate the Boltzman and frequency factor of the C intensity C G=1.0 CONV2=1.438769 IF (INT.EQ.1.and.ee(2).gt.0.and.ee(1).gt.0.)THEN BETA = (CONV2/TPR) * (-EE(1) - EVIB(1)) BLTZ = EXP(BETA) BLNU = 1 - EXP(-ECALC*(CONV2/TPR)) BLTZ2 = BLTZ*ECALC*BLNU*G C print*,'BLTZ=',BLTZ c PRINT*,'ECALC=',ECALC,'CONV2=',CONV2,'BLTZ2=',BLTZ2 c 1,'EE(2)=',EE(2),'EE(1)=',EE(1),'BLTZ=',BLTZ,'BLNU=',BLNU, c 2'TPR=',TPR END IF 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 C IS MOLECULE DEPENDANT:DHERE IT IS FOR CH3CHO ONLY! 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 ccikdebug change of 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 ELSEIF(KT1K.EQ.-2.OR.KT1K.EQ.3) THEN KC(1,K)=NOBS(1,K)-2 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 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) cikdebug, change of sign! IF(KT2K.EQ.0.OR.KT2K.EQ.1) THEN KC(2,K)=NOBS(2,K) 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) 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 IF(INT.NE.1) THEN 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), 2 PROBS(1,K),EOBS,IW(K),ECALC,TME2,REF(K),EE(2),EE(1) 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,F10.3, 2 1X,A6,1X,F9.4,1X,F9.4) 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 (INT.EQ.1.and.ee(2).gt.0.and.ee(1).gt.0.)THEN CALL INTEN(RINT,CST,K,IVV,INK,MUABC,ICTT,CF) WRITE(6,7834) 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), 2 PROBS(1,K),EOBS,IW(K),ECALC,AINCER(K),TME2,rint 3 ,EE(2),EE(1),REF(K) c WRITE(6,*) EE(1),EE(2),'BLTZ=',BLTZ,'BLTZ2=',BLTZ2,'SSQ=',SSQ 7834 FORMAT(1X,I3,1X,I3,1X,I3,1X,I3,1X,A1,1X,I,1X,I3,1X,I3, 1 1X,I3,1X,A1,1X,F12.3,'(',I3,')',1X,F12.3,'(',F5.3')' 2 ,2X,F12.3,1X,F10.3,1X,F9.4,1X,F9.4,1X,A6) ENDIF ELSEIF(IW(K).EQ.10) THEN IW(K)=5 WRITE(6,634) 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), 2 PROBS(1,K),EOBS,IW(K),ECALC,TME2,IAST(K),REF(K) 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) WRITE(6,635) 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), 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) WRITE(6,635) 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), 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 EOBS=EOBS*29979.2458 ECALC=ECALC*29979.2458 TME3=TME3*29979.2458 AST='*' if(INT.NE.1) THEN 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), 2 PROBS(1,K),EOBS,ECALC,TME3,AST,REF(K),EE(2),EE(1) ELSEIF(INT.EQ.1) THEN CALL INTEN(RINT,CST,K,IVV,INK,MUABC,ICTT,CF) WRITE(6,7834) 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), 2 PROBS(1,K),EOBS,IW(K),ECALC,AINCER(K),TME3,rint 3 ,EE(2),EE(1),REF(K) c WRITE(6,*) EE(1),EE(2),'BLTZ=',BLTZ,'BLTZ2=',BLTZ2,'SSQ=',SSQ c SSQ= line strength ENDIF ELSE TME2=EOBS-ECALC AST='*' IF(INT.NE.1) THEN WRITE(6,608) 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), 2 PROBS(1,K),EOBS,ECALC,TME2,AST,REF(K),EE(2),EE(1) ELSEIF(INT.EQ.1) THEN CALL INTEN(RINT,CST,K,IVV,INK,MUABC,ICTT,CF) WRITE(6,7834) 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), 2 PROBS(1,K),EOBS,IW(K),ECALC,AINCER(K),TME3,rint 3 ,EE(2),EE(1),REF(K) ENDIF 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,6X,F12.3,2X,F7.3,1X,A1,1X,A6, 2 1X,F9.4,1X,F9.4) 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,803) SWA WRITE(6,804) SWE 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,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.MWA(UNITLESS) = ',F20.4,2X,I4) 802 FORMAT(/,' RMS.DEV.MWE(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.004MHZ',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) 803 FORMAT(/,' RMS.DEV.MICRONDE A(MHZ)= ',F20.4) 804 FORMAT(/,' RMS.DEV.MICRONDE E(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) 888 FORMAT(/,' RMS.DEV.GROUND STATE DIFF.VT=0 (CM-1)) = ',F20.6) 890 FORMAT(/,' RMS.DEV.MICROWAVE,WEIGHT=0.004MHZ',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*834 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,20000),REF(20000) COMMON/SYMB/ABC DIMENSION CST(2,139) 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 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(20000),IVOBS(2,20000), * NOBS(2,20000),KOBS(2,20000),IBLK(2,20000),IW(20000),W(20000), * NDATA,NADAT,EPSI,NOFIT,NFITMW,NFITIR,NFIMW0 ,NFIMW1 ,NITT, * IAST(20000),NFI004 ,NFI080 ,NFI100 ,NFI020 ,NFI200 ,NFI045 , & NGST0 ,NFI010 ,SW070,NFI070 ,NFIMW2,IKAKC,JMAX,NFI1M0, & NFIR10,NFIR21,NFIR32,NFIMW3,NFIMW4,SWA,SWE,NFITMWA,NFITMWE &,INT COMMON/CNTL/NIT,IEND,DELTAS,S,TME(20000),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,IISIG COMMON/CHARA/PARA(2,160),PR,PROBS(2,20000),REF(20000) C REJLIM = 3*S WRITE(6,803) REJLIM IREJL = 10000 * REJLIM DO 88 I = 1, NDATA IF (IAST(I) .EQ. 0) THEN ITME = 10000 * dABS(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 1,NN=(30)+1,ISIGMA=(2)) COMMON/QUANT/ISIG,IV,N,KK,IISIG COMMON/CHARA/PARA(2,160),PR,PROBS(2,20000),REF(20000) COMMON/ROTOR/NROTOR,NDIMTO DIMENSION CST(2,139),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,EGVCR,EGVCI) 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 1,NN=(30)+1,ISIGMA=(2)) COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRON1 , * IBGTME,IBGVTD ,EVIB(2),IRMW,TERM COMMON/QUANT/ISIG,IV,N,KK,IISIG COMMON/CHARA/PARA(2,160),PR,PROBS(2,20000),REF(20000) DIMENSION IPST(3*(2*(30)+1)),EGVL(NDMX),EGVCR(NDMX,NDMX) DIMENSION EGVCI(NDMX,NDMX) WRITE(6,*)' N= ',N,' ISIG= ',ISIG WRITE(6,50) 50 FORMAT(/,' TYPE E ',/) NN1=2*N+1 NNT=NN1*4 DO 1 J=1,NNT CST=0.0 DO 2 I=1,NNT C=dcmplx(EGVCR(I,J),-EGVCI(I,J))* 1dcmplx(EGVCR(I,J),EGVCI(I,J)) c 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 c CC=EGVC(K,J)**2 CC=dcmplx(EGVCR(K,J),-EGVCI(K,J))* 1dcmplx(EGVCR(K,J),EGVCI(K,J)) IF(CC.GE.(CST*0.7D0)) THEN PUR(J)='*' GO TO 5 ENDIF 4 CONTINUE 5 IVT=0 DO 3 KKK=1,(04) IN=NN1*KKK IF (IPST(J).GT.IN) IVT=IVT+1 3 CONTINUE K=IPST(J)-(N+1)-IVT*NN1 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,EGVCR,EGVCI) 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 1,NN=(30)+1,ISIGMA=(2)) COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRON1 , * IBGTME,IBGVTD ,EVIB(2),IRMW,TERM COMMON/QUANT/ISIG,IV,N,KK,IISIG COMMON/CHARA/PARA(2,160),PR,PROBS(2,20000),REF(20000) DIMENSION EGVL(NDMX),EGVCR(NDMX,NDMX) DIMENSION EGVCI(NDMX,NDMX) WRITE(6,*) ' N= ',N,' ISIG= ',ISIG WRITE(6,50) 50 FORMAT(/,' TYPE A ',/) NN1=2*N+1 NNT=NN1*4 DO 1 J=1,NNT IVT=0 DO 3 KKK=1,(04) IN=NN1*KKK IF (J.GT.IN) IVT=IVT+1 3 CONTINUE K=(N*J+N-IVT*N*NN1)/NN1 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,EGVCR,EGVCI,ETOR,A) 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*834 CHARACTER*1 PR,PROBS CHARACTER*6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1 1,NN=(30)+1,ISIGMA=(2)) COMMON/EIGEN/HR(NDMX,NDMX),HI(NDMX,NDMX),WORK(NDMX), *EGVC3R(KDMX,9),EGVC3I(KDMX,9),NBR(2),VECTPR(10,961,KDMX,9) *,VECTPI(10,961,KDMX,9) 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,IISIG COMMON/CHARA/PARA(2,160),PR,PROBS(2,20000),REF(20000) DIMENSION CST(2,139),UNIT(160,160),WKSPCE(160),EGVL(NDMX) DIMENSION EGVCR(NDMX,NDMX),ETOR(KDMX,9) complex(8) H(NDMX,NDMX) complex(8) A(9,NTORMX,2*KDMX,NN,ISIGMA) DIMENSION EGVCI(NDMX,NDMX),HR2(NDMX,NDMX),HI2(NDMX,NDMX) DIMENSION EGVC(NDMX,NDMX) C KTRON1 =KTRONC+1 NDIMTO =2*KTRONC+1 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(IBUG3.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',/) print*,'real, K=',K,'N=',N,'isig=',isig CALL MATOUT(HR,NDMX,NDMX,NDIMTO ,NDIMTO ) print*,'imaginary, K=',K,'N=',N,'isig=',isig CALL MATOUT(HI,NDMX,NDMX,NDIMTO ,NDIMTO ) ENDIF C C PERFORMS DIAGONALISATION(CRAY SUBROUTINES) C c CALL TRED2(NDMX,NDIMTO,HR,EGVL,WORK,EGVCR) c CALL TQL2(NDMX,NDIMTO ,EGVL,WORK,EGVCR,IERR) CALL EISCH1(NDMX,NDIMTO,HR,HI,EGVL,EGVCR,EGVCI,IERR,WORK) IF (IERR.NE.0) THEN WRITE(6,62) 62 FORMAT(/,' DIAGONALISATION FAILED FOR TORSION ',/) STOP ENDIF do 88 ij=1,NROTOR c JJ1=N*(N+1) c EGVLRE(IJ)=EGVL(ij)-JJ1*0.30 c if(LO.EQ.2.and.isig.eq.0.and.egvlre(ij).GE.450.and.EGVLRE(IJ) c 1.LT.900.) then if(LO.EQ.1.and.ISIG.EQ.0) then cc write(9,*) egvl(ij),'N=',N c elseif(LO.EQ.2.and.isig.eq.1.and.egvlre(ij).GE.450.and.EGVLRE(IJ) c 1.LT.900.) then elseif(LO.EQ.1.AND.ISIG.EQ.1) then cc write(10,*) egvl(ij),'N=',N endif 88 continue IF(IBUG1.NE.0) WRITE(6,81) 81 FORMAT(//,' TORSION EIGENVALUES AND EIGENVECTORS ',//) IF (IBUG1.NE.0) THEN print*,'real, K=',K,'N=',N,'isig=',isig CALL MATOU2 (EGVCR,EGVL,NDMX,NDMX,NDIMTO ,NDIMTO ) print*,'imaginary, K=', K,'N=',N,'isig=',isig CALL MATOU2 (EGVCI,EGVL,NDMX,NDMX,NDIMTO ,NDIMTO ) ENDIF IF(IBUG3.NE.0) CALL RESUM1(LO,EGVL) C C STOCKS THE EIGENVECTORS IN A 3-DIMENSION MATRIX A C CALL ASET(K,EGVL,EGVCR,EGVCI,ETOR,A,CST) 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.AND.N.EQ.2.AND.ISIG.EQ.0) THEN WRITE(6,73) 73 FORMAT(/,' ROTATION-TORSION MATRIX TO BE 1 DIAGONALISED ',/) print*,'HR=' CALL MATOUT(HR,NDMX,NDMX,NROTOR,NROTOR) print*,'HI=' CALL MATOUT(HI,NDMX,NDMX,NROTOR,NROTOR) ENDIF C C PERFORMS DIAGONALISATION C c IF(N.EQ.0) then c CALL TRED2(NDMX,NROTOR,HR,EGVL,WORK,EGVCR) c CALL TQL2(NDMX,NROTOR,EGVL,WORK,EGVCR,IERR) c ELSE CALL EISCH1(NDMX,NROTOR,HR,HI,EGVL,EGVCR,EGVCI,IERR,WORK) c ENDIF IF (IERR.NE.0) THEN WRITE(6,72) 72 FORMAT(/,' DIAGONALISATION FAILED FOR ROTATION- 1 TORSION ',/) STOP ENDIF IF(IBUG3.NE.0) WRITE(6,71) c IF (IBUG2.NE.0) THEN C IF (IBUG2.NE.0.AND.N.EQ.13.OR.IBUG2.NE.0.AND.N.EQ.14)THEN IF (IBUG2.NE.0.AND.N.EQ.2.AND.ISIG.EQ.0) THEN c PRINT*,' N= ',N,'ISIG=',ISIG print*,'EGVCR=' CALL MATOU2 (EGVCR,EGVL,NDMX,NDMX,NROTOR,NROTOR) print*,'EGVCI=' CALL MATOU2 (EGVCI,EGVL,NDMX,NDMX,NROTOR,NROTOR) ENDIF 71 FORMAT(//,' ROTATION-TORSION EIGENVALUES AND 1 EIGENVECTORS ',//) IF(IBUG3.NE.0.OR.IBUG4.NE.0) THEN IF(ISIG.EQ.1) THEN CALL RESUM2(LO,EGVL,EGVCR,EGVCI) ELSE CALL RESUM3(LO,EGVL,EGVCR,EGVCI) ENDIF ENDIF REWIND 31 REWIND 32 REWIND 33 REWIND 34 END 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*834 CHARACTER*6 PARA,REF CHARACTER*1 PR,PROBS PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1 1,NN=(30)+1,ISIGMA=(2)) COMMON/EIGEN/HR(NDMX,NDMX),HI(NDMX,NDMX),WORK(NDMX), *EGVC3R(KDMX,9),EGVC3I(KDMX,9),NBR(2),VECTPR(10,961,KDMX,9) *,VECTPI(10,961,KDMX,9) COMMON/EIGEN1/EGVL(2*NDMX),EGVC(NDMX,2*NDMX) *,EGVCR(NDMX,2*NDMX),EGVCI(NDMX,2*NDMX) COMMON/TOR/A(9,NTORMX,2*KDMX,NN,ISIGMA),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/DERIVR(10,961,80),ENER(10,961),DERIVI(10,961,80) COMMON/EXPDAT / ETRANS(20000),IVOBS(2,20000), * NOBS(2,20000),KOBS(2,20000),IBLK(2,20000),IW(20000),W(20000), * NDATA,NADAT,EPSI,NOFIT,NFITMW,NFITIR,NFIMW0 ,NFIMW1 ,NITT, * IAST(20000),NFI004 ,NFI080 ,NFI100 ,NFI020 ,NFI200 ,NFI045 , & NGST0 ,NFI010 ,SW070,NFI070 ,NFIMW2,IKAKC,JMAX,NFI1M0, & NFIR10,NFIR21,NFIR32,NFIMW3,NFIMW4,SWA,SWE,NFITMWA,NFITMWE &,INT COMMON/SYMB/ABC COMMON/QUANT/ISIG,IV,N,KK,IISIG COMMON/CHARA/PARA(2,160),PR,PROBS(2,20000),REF(20000) DIMENSION UNIT(160,160),VR(160),CST(2,139) DIMENSION VI(160) complex(8) V1R(160),V1I(160),V2R(160),V2I(160) complex(8) A C C INITIALIZATION JJMAX=(JMAX+1)**2 MAX=2*(30)+1 DO 99 I=1,10 DO 100 J=1,JJMAX DO 101 JJ=1,NP(1) ENER(I,J)=0.d0 DERIVR(I,J,JJ)=0.d0 DERIVI(I,J,JJ)=0.d0 101 CONTINUE DO 200 IN=1,MAX DO 201 INN=1,9 VECTPR(I,J,IN,INN)=0.d0 VECTPI(I,J,IN,INN)=0.d0 201 CONTINUE 200 CONTINUE 100 CONTINUE 99 CONTINUE LO=1 NI=1 M=1 LOO=LO DO 5 ISIG=0,1 IISIG=ISIG+1 IF(ISIG.EQ.1) THEN DO 20 N=0,JMAX CALL ROTTOR(CST,LO,EGVL(NI),EGVCR(1,NI), 1 EGVCI(1,NI),ETOR(M,1),A(1,1,M,1,1)) NROTOR=(2*N+1)*9 DO 10 IV=0,4 DO 30 KK=-N,N CALL ENCAL(E,LOO,EGVL(NI),EGVCR(1,NI), 1 EGVCI(1,NI),A) CALL VSET(1,V1R,V1I,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 IF(INT.EQ.1) THEN 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) VECTPR(IV+6,INK,II,IVTORP)=EGVC3R(II,IVTORP) VECTPI(IV+6,INK,II,IVTORP)=EGVC3I(II,IVTORP) 3 CONTINUE ENDIF C PRINT*,'INK=',INK,'ENER=',ENER DO 40 I=1,NP(1) DERIVR(IV+6,INK,I)=dREAL(V1R(I)+V1I(I)) DERIVI(IV+6,INK,I)=dIMAG(V1R(I)+V1I(I)) C IF(N.EQ.1) THEN C PRINT*,'V1=',V1(I),'DERIV=',DERIV(IV+6,INK,I),'IV=',IV, C 1 'INK=',INK,'ISIG=',ISIG C ENDIF 40 CONTINUE 30 CONTINUE 10 CONTINUE 20 CONTINUE ELSE DO 21 N=0,JMAX CALL ROTTOR(CST,LO,EGVL(NI),EGVCR(1,NI), 1 EGVCI(1,NI),ETOR(M,1) 2 ,A(1,1,M,1,1)) NROTOR=(2*N+1)*9 DO 11 IV=0,4 DO 31 KK=0,N IF(KK.EQ.0) THEN PR='+' IPR=1 CALL ENCAL(E,LOO,EGVL(NI),EGVCR(1,NI), 1 EGVCI(1,NI),A) CALL VSET(1,V1R,V1I,CST) INK=N**2+N+KK+1-IPR*N ENER(IV+1,INK)=E c IF(N.EQ.12.AND.IV.EQ.0) PRINT*,'E=',E,'INK=',INK IF(INT.EQ.1) THEN 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) VECTPR(IV+1,INK,II,IVTORP)=EGVC3R(II,IVTORP) VECTPI(IV+1,INK,II,IVTORP)=EGVC3I(II,IVTORP) 4 CONTINUE ENDIF DO 41 I=1,NP(1) DERIVR(IV+1,INK,I)=dREAL(V1R(I)+V1I(I)) DERIVI(IV+1,INK,I)=dIMAG(V1R(I)+V1I(I)) c if(N.EQ.12.AND.IV.EQ.0) print*,'derivI=',derivi(IV+1,INK,I) c 1,'I=',I c if(N.EQ.12.AND.IV.EQ.0) print*,'derivR=',derivR(IV+1,INK,I) c 1,'I=',I C IF(N.EQ.2) THEN C PRINT*,'V1=',V1(I),'DERIV=',DERIV(IV+1,INK,I),'IV=',IV, C 1 'INK=',INK,'ISIG=',ISIG C 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),EGVCR(1,NI), 1 EGVCI(1,NI),A) CALL VSET(1,V1R,V1I,CST) ENER(IV+1,INK)=E c IF(N.EQ.2.AND.IV.EQ.0) PRINT*,'E=',E,'INK=',INK C PRINT*,'ENER=',ENER,'INK=',INK IF(INT.EQ.1) THEN IVTORP=1 DO 6 I=1,NROTOR IU=(2*N+1)*IVTORP+1 IF(I.EQ.IU) IVTORP=IVTORP+1 II=I-(2*N+1)*(IVTORP-1) VECTPR(IV+1,INK,II,IVTORP)=EGVC3R(II,IVTORP) VECTPI(IV+1,INK,II,IVTORP)=EGVC3I(II,IVTORP) 6 CONTINUE ENDIF DO 42 I=1,NP(1) DERIVR(IV+1,INK,I)=dREAL(V1R(I)+V1I(I)) DERIVI(IV+1,INK,I)=dIMAG(V1R(I)+V1I(I)) c print*,'derivr=',derivr(IV+1,INK,I) c 1 ,'derivi=',derivi(IV+1,INK,I) C IF(N.EQ.1) THEN C PRINT*,'V1=',V1(I),'DERIV=',DERIV(IV+1,INK,I),'IV=',IV, C 1 'INK=',INK,'ISIG=',ISIG C ENDIF 42 CONTINUE 32 CONTINUE ENDIF 31 CONTINUE 11 CONTINUE 21 CONTINUE ENDIF 5 CONTINUE 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) 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 1,NN=(30)+1,ISIGMA=(2)) COMMON/EIGEN/HR(NDMX,NDMX),HI(NDMX,NDMX),WORK(NDMX), *EGVC3R(KDMX,9),EGVC3I(KDMX,9),NBR(2),VECTPR(10,961,KDMX,9) *,VECTPI(10,961,KDMX,9) COMMON / CHARA / PARA (2,160), PR, PROBS (2,20000), REF (20000) COMMON/QUANT/ISIG,IV,N,KK,IISIG complex(8) YCONJ,Y,VRTDI1,VRTDIA,VRTDIB,VRTDIC,VRTDID * complex(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) & ,A1T4M(KDMX,9,9) & ,A2T4M(KDMX,9,9),A3T4M(KDMX,9,9),A1T2M(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 & ,A1T4M,A2T4M,A3T4M,A1T2M * complex(8) EGTA(KDMX,9,9) * DO 1004 IVTORP = 1,9 DO 1002 IVTOR1 = 1,9 DO 1000 I = 1, 2 * N + 1 YCONJ=dcmplx(EGVC3R(I,IVTORP),-EGVC3I(I,IVTORP)) Y=dcmplx(EGVC3R(I,IVTOR1),EGVC3I(I,IVTOR1)) c EGTA(I,IVTOR1,IVTORP) = EGVC3(I,IVTORP) * EGVC3(I,IVTOR1) EGTA(I,IVTOR1,IVTORP) = YCONJ*Y & * 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,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,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,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,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) 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 1,NN=(30)+1,ISIGMA=(2)) COMMON/EIGEN/HR(NDMX,NDMX),HI(NDMX,NDMX),WORK(NDMX), *EGVC3R(KDMX,9),EGVC3I(KDMX,9),NBR(2),VECTPR(10,961,KDMX,9) *,VECTPI(10,961,KDMX,9) COMMON/QUANT/ISIG,IV,N,KK,IISIG COMMON / CHARA / PARA (2,160), PR, PROBS (2,20000), REF (20000) complex(8) YCONJ,Y,VRTDI2,YY complex(8) VRTDIA,VRTDIB,VRTDIC,VRTDID,VRTDIE,VRTDII,VRTDIJ complex(8) VRTDIK,VRTDIF,VRTDIG,VRTDIG2,VRTDIG3,VRTDIH complex(8) VRTDIL,VRTDIM,VRTDIAM,VRTDIAP * complex(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) & ,A1T4M(KDMX,9,9) & ,A2T4M(KDMX,9,9),A3T4M(KDMX,9,9),A1T2M(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 & ,A1T4M,A2T4M,A3T4M,A1T2M * complex(8) EGT(KDMX,9,9),SQT(KDMX),EGTM(KDMX,9,9),SQTM(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 YCONJ=dcmplx(EGVC3R(I,IVTORP),-EGVC3I(I,IVTORP)) Y=dcmplx(EGVC3R(I+2,IVTOR1),EGVC3I(I+2,IVTOR1)) c EGT(I,IVTOR1,IVTORP) = SQT(I) * EGVC3(I,IVTORP) c & * EGVC3(I+2,IVTOR1) EGT(I,IVTOR1,IVTORP) = SQT(I) * YCONJ*Y 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,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) vrtdia=dreal(vrtdia) 7000 CONTINUE 7002 CONTINUE 7004 CONTINUE END IF * * IF (PARA(LO,L).EQ.'ODELK '.OR. PARA(LO,L).EQ.'OHJK ') THEN VRTDIB = (0.0,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) vrtdib=dreal(vrtdib) 7010 CONTINUE 7012 CONTINUE 7014 CONTINUE END IF * IF (PARA(LO,L).EQ.'OHK ') THEN VRTDIC = (0.0,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) vrtdic=dreal(vrtdic) 7020 CONTINUE 7022 CONTINUE 7024 CONTINUE END IF * IF (PARA(LO,L).EQ.'C1 ' .OR. PARA(LO,L).EQ.'C1J ') THEN VRTDID = (0.0,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) vrtdid=dreal(vrtdid) 7030 CONTINUE 7032 CONTINUE 7034 CONTINUE END IF * IF (PARA(LO,L).EQ.'C1K ') THEN VRTDII = (0.0,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) vrtdii=dreal(vrtdii) 7080 CONTINUE 7082 CONTINUE 7084 CONTINUE END IF IF (PARA(LO,L).EQ.'C2 ' .OR. PARA(LO,L).EQ.'C2J ') THEN VRTDIE = (0.0,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))) vrtdie=dreal(vrtdie) 7040 CONTINUE 7042 CONTINUE 7044 CONTINUE END IF * IF (PARA(LO,L).EQ.'C2K ')THEN VRTDIJ = (0.0,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) vrtdij=dreal(vrtdij) 7090 CONTINUE 7092 CONTINUE 7094 CONTINUE END IF IF (PARA(LO,L).EQ.'C11 ') THEN VRTDIK = (0.0,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))) vrtdik=dreal(vrtdik) 7240 CONTINUE 7242 CONTINUE 7244 CONTINUE END IF * IF (PARA(LO,L).EQ.'C3 '.OR.PARA(LO,L).EQ.'C3J ') THEN VRTDIF = (0.0,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) vrtdif=dreal(vrtdif) 7050 CONTINUE 7052 CONTINUE 7054 CONTINUE END IF * IF (PARA(LO,L).EQ.'DBC ') THEN VRTDIG = (0.0,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)) vrtdig=dreal(vrtdig) 7060 CONTINUE 7062 CONTINUE 7064 CONTINUE END IF * IF (PARA(LO,L).EQ.'DBCJ ') THEN VRTDIG3= (0.0,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)) vrtdig3=dreal(vrtdig3) 8060 CONTINUE 8062 CONTINUE 8064 CONTINUE END IF IF (PARA(LO,L).EQ.'DBC12 ') THEN VRTDIG2= (0.0,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)) vrtdig2=dreal(vrtdig2) 2060 CONTINUE 2062 CONTINUE 2064 CONTINUE END IF * IF (PARA(LO,L).EQ.'C4 '.OR.PARA(LO,L).EQ.'C4J ')THEN VRTDIH = (0.0,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) vrtdih=dreal(vrtdih) 7070 CONTINUE 7072 CONTINUE 7074 CONTINUE END IF * IF (PARA(LO,L).EQ.'C12 '.OR.PARA(LO,L).EQ.'C12J ')THEN VRTDIL = (0.0,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) vrtdil=dreal(vrtdil) 7100 CONTINUE 7102 CONTINUE 7104 CONTINUE END IF * IF (PARA(LO,L).EQ.'C4K ') THEN VRTDIM = (0.0,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) vrtdim=dreal(vrtdim) 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.'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 VRTDI2I (L, LO) 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 1,NN=(30)+1,ISIGMA=(2)) COMMON/EIGEN/HR(NDMX,NDMX),HI(NDMX,NDMX),WORK(NDMX), *EGVC3R(KDMX,9),EGVC3I(KDMX,9),NBR(2),VECTPR(10,961,KDMX,9) *,VECTPI(10,961,KDMX,9) COMMON/QUANT/ISIG,IV,N,KK,IISIG COMMON / CHARA / PARA (2,160), PR, PROBS (2,20000), REF (20000) complex(8) YCONJ,Y,VRTDI2I * complex(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) & ,A1T4M(KDMX,9,9) & ,A2T4M(KDMX,9,9),A3T4M(KDMX,9,9),A1T2M(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 & ,A1T4M,A2T4M,A3T4M,A1T2M * complex(8) EGT(KDMX,9,9),SQT(KDMX) complex(8) VRTDIE,VRTDIK,VRTDIG,VRTDIG3,VRTDIG2,VRTDIJ * 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 YCONJ=dcmplx(EGVC3R(I,IVTORP),-EGVC3I(I,IVTORP)) Y=dcmplx(EGVC3R(I+2,IVTOR1),EGVC3I(I+2,IVTOR1)) c EGT(I,IVTOR1,IVTORP) = SQT(I) * EGVC3(I,IVTORP) c & * EGVC3(I+2,IVTOR1) EGT(I,IVTOR1,IVTORP) = SQT(I) * YCONJ*Y 1000 CONTINUE 1002 CONTINUE 1004 CONTINUE * IF (PARA(LO,L).EQ.'C2I ' .OR. PARA(LO,L).EQ.'C2JI ') THEN VRTDIE =(0.0,0.0) DO 5044 IVTORP = 1,9 DO 5042 IVTOR1 = 1,9 DO 5040 I = 1, 2 * N - 1 VRTDIE = VRTDIE + EGT(I,IVTOR1,IVTORP) & * 0.5 * (-A4T2(I,IVTOR1,IVTORP) & + A5T2(I,IVTOR1,IVTORP)) 5040 CONTINUE 5042 CONTINUE 5044 CONTINUE END IF * IF (PARA(LO,L).EQ.'C2KI ')THEN VRTDIJ = (0.0,0.0) DO 5094 IVTORP = 1,9 DO 5092 IVTOR1 = 1,9 DO 5090 I = 1, 2 * N - 1 K=I-N-1 VRTDIJ = VRTDIJ + EGT(I,IVTOR1,IVTORP) & * 0.5 * (-A4T2(I,IVTOR1,IVTORP) & + A5T2(I,IVTOR1,IVTORP)) & *(K**2+(K+2)**2) 5090 CONTINUE 5092 CONTINUE 5094 CONTINUE END IF * IF (PARA(LO,L).EQ.'C11I ') THEN VRTDIK = (0.0,0.0) DO 5244 IVTORP = 1,9 DO 5242 IVTOR1 = 1,9 DO 5240 I = 1, 2 * N - 1 VRTDIK = VRTDIK + EGT(I,IVTOR1,IVTORP) & * 0.5 * (-A8T2(I,IVTOR1,IVTORP) & + A9T2(I,IVTOR1,IVTORP)) 5240 CONTINUE 5242 CONTINUE 5244 CONTINUE END IF * IF (PARA(LO,L).EQ.'DBCI ') THEN VRTDIG = (0.0,0.0) DO 5064 IVTORP = 1,9 DO 5062 IVTOR1 = 1,9 DO 5060 I = 1, 2 * N - 1 VRTDIG = VRTDIG + EGT(I,IVTOR1,IVTORP) & *(A1T2(I,IVTOR1,IVTORP) )*(2.) 5060 CONTINUE 5062 CONTINUE 5064 CONTINUE END IF * IF (PARA(LO,L).EQ.'ODBCI ') THEN VRTDIG3= (0.0,0.0) DO 6064 IVTORP = 1,9 DO 6062 IVTOR1 = 1,9 DO 6060 I = 1, 2 * N - 1 VRTDIG3= VRTDIG3+ EGT(I,IVTOR1,IVTORP) & *(A1T2(I,IVTOR1,IVTORP)-0.5 & * (A4T2(I,IVTOR1,IVTORP) + A5T2(I,IVTOR1,IVTORP))) cik debug & *(2.) c & * (N*(N+1)) 6060 CONTINUE 6062 CONTINUE 6064 CONTINUE END IF IF (PARA(LO,L).EQ.'DBC12 ') THEN VRTDIG2= (0.0,0.0) DO 4064 IVTORP = 1,9 DO 4062 IVTOR1 = 1,9 DO 4060 I = 1, 2 * N - 1 VRTDIG2= VRTDIG2+ EGT(I,IVTOR1,IVTORP) & *(A1T1(I,IVTOR1,IVTORP)-0.5 & * (A4T2B(I,IVTOR1,IVTORP) + A5T2B(I,IVTOR1,IVTORP))) 4060 CONTINUE 4062 CONTINUE 4064 CONTINUE END IF * IF (PARA(LO,L).EQ.'C2I ') THEN VRTDI2I= 0.5 * VRTDIE c if(N.EQ.2.AND.ISIG.EQ.0) print*,'vrtdi2I=',vrtdi2I ELSE IF (PARA(LO,L).EQ.'C2JI ') THEN VRTDI2I= 0.5 * VRTDIE * N*(N+1) ELSE IF (PARA(LO,L).EQ.'C11I ') THEN VRTDI2I= 0.5 * VRTDIK ELSE IF (PARA(LO,L).EQ.'DBCI ') THEN cik debug: attention DBCI a seulement un facteur 1/4 (et pas c un facteur 1/2 en plus car pas de sin) VRTDI2I= -0.25*VRTDIG ELSE IF (PARA(LO,L).EQ.'ODBCI ') THEN VRTDI2I= -0.25*VRTDIG3 ELSE IF (PARA(LO,L).EQ.'C2KI ') THEN VRTDI2I=0.5* VRTDIJ END IF END C*********************************************************** FUNCTION VRTDI4 (L, LO) 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 1,NN=(30)+1,ISIGMA=(2)) COMMON/EIGEN/HR(NDMX,NDMX),HI(NDMX,NDMX),WORK(NDMX), *EGVC3R(KDMX,9),EGVC3I(KDMX,9),NBR(2),VECTPR(10,961,KDMX,9) *,VECTPI(10,961,KDMX,9) COMMON / CHARA / PARA (2,160), PR, PROBS (2,20000), REF (20000) COMMON/QUANT/ISIG,IV,N,KK,IISIG complex(8) YCONJ,Y,VRTDI4 * complex(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) & ,A1T4M(KDMX,9,9) & ,A2T4M(KDMX,9,9),A3T4M(KDMX,9,9),A1T2M(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 & ,A1T4M,A2T4M,A3T4M,A1T2M * complex(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 YCONJ=dcmplx(EGVC3R(I,IVTORP),-EGVC3I(I,IVTORP)) Y=dcmplx(EGVC3R(I+1,IVTOR1),EGVC3I(I+1,IVTOR1)) c EGT(I,IVTOR1,IVTORP) = SQT(I) * EGVC3(I,IVTORP) c & * EGVC3(I+1,IVTOR1) EGT(I,IVTOR1,IVTORP) = SQT(I) * YCONJ*Y c if(N.EQ.2) print*,'egt=',egt(I,IVTOR1,iVTORP),'YCONJ=',YCONJ, c 1'Y=',Y,'SQT=',SQT(I),'EGVC3R=',EGVC3R(I,IVTORP),'EGVC3I=', c 2EGVC3I(I,IVTORP) 1000 CONTINUE 1002 CONTINUE 1004 CONTINUE * VRTDI4 = (0.0,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) vrtdi4=dreal(vrtdi4) c if(N.EQ.2) print*,'VRTDI4=',VRTDI4,'A1T4=', c 1A1T4(I,IVTOR1,IVTORP) c 2,'egt=',EGT(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) vrtdi4=dreal(vrtdi4) 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))) vrtdi4=dreal(vrtdi4) 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))) vrtdi4=dreal(vrtdi4) 8014 CONTINUE 8012 CONTINUE 8010 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))) vrtdi4=dreal(vrtdi4) 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) vrtdi4=dreal(vrtdi4) 7024 CONTINUE 7022 CONTINUE 7020 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) vrtdi4=dreal(vrtdi4) 7034 CONTINUE 7032 CONTINUE 7030 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) cik remark: A3T4=k'=k+1, A4T4=k'=k-1, the (-) sign that appears in H1 c is thus taken into account. VRTDI4 = VRTDI4 + EGT(I,IVTOR1,IVTORP) & * (I - N - 0.5) & * (A3T4(I,IVTOR1,IVTORP) - A4T4(I,IVTOR1,IVTORP)) vrtdi4=dreal(vrtdi4) 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)) vrtdi4=dreal(vrtdi4) 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)) vrtdi4=dreal(vrtdi4) 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) vrtdi4=dreal(vrtdi4) 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) vrtdi4=dreal(vrtdi4) 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) vrtdi4=dreal(vrtdi4) 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) vrtdi4=dreal(vrtdi4) 8064 CONTINUE 8062 CONTINUE 8060 CONTINUE END IF * END C******************************************************************** FUNCTION VRTDI4I (L, LO) 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 1,NN=(30)+1,ISIGMA=(2)) COMMON/EIGEN/HR(NDMX,NDMX),HI(NDMX,NDMX),WORK(NDMX), *EGVC3R(KDMX,9),EGVC3I(KDMX,9),NBR(2),VECTPR(10,961,KDMX,9) *,VECTPI(10,961,KDMX,9) COMMON / CHARA / PARA (2,160), PR, PROBS (2,20000), REF (20000) COMMON/QUANT/ISIG,IV,N,KK,IISIG complex(8) YCONJ,Y,VRTDI4I,YM,vrtdi4p,vrtdi4m,vrtdi4j * complex(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) & ,A1T4M(KDMX,9,9) & ,A2T4M(KDMX,9,9),A3T4M(KDMX,9,9),A1T2M(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 & ,A1T4M,A2T4M,A3T4M,A1T2M * complex(8) EGT(KDMX,9,9),SQT(KDMX),egt2,EGTM(KDMX,9,9) complex(8) SQTM(KDMX) * DO 500 I = 1, 2 * N SQT(I) = SQRT (FLOAT(N*(N+1) - (I-N-1)*(I-N))) 500 CONTINUE DO 501 I = 2, 2 * N +1 SQTM(I) = SQRT (FLOAT(N*(N+1) - (I-N-1)*(I-N-2))) 501 CONTINUE egt2=(0.0,0.0) DO 1004 IVTORP = 1,9 DO 1002 IVTOR1 = 1,9 DO 1000 I = 1, 2 * N+1 YCONJ=dcmplx(EGVC3R(I,IVTORP),EGVC3I(I,IVTORP)) YCONJ=dconjg(YCONJ) if(I.LE.2*N) then Y=dcmplx(EGVC3R(I+1,IVTOR1),EGVC3I(I+1,IVTOR1)) else Y=(0.,0.) endif if(I.ne.1) then YM=dcmplx(EGVC3R(I-1,IVTOR1),EGVC3I(I-1,IVTOR1)) else YM=(0.,0.) endif c EGT(I,IVTOR1,IVTORP) = SQT(I) * EGVC3(I,IVTORP) c & * EGVC3(I+1,IVTOR1) EGT(I,IVTOR1,IVTORP) = SQT(I) * YCONJ*Y EGTM(I,IVTOR1,IVTORP) = SQTM(I) * YCONJ*YM egt2=egt2+Yconj*y c if(N.EQ.2) then c print*,'egt=',egt(I,ivtor1,ivtorp), c 1'egtm=',egtm(I,ivtor1,ivtorp) c 2,'I=',I,'ivtor1=',ivtor1,'ivtorp=',ivtorp c 3,'egvc3R=',EGVC3R(I,IVTORP),'EGVC3I=',EGVC3I(I,IVTORP) c 4,'egvc3R-1=',EGVC3R(I-1,IVTORP),'EGVC3I-1=',EGVC3I(I-1,IVTORP) c 2,'SQT=',SQT(I) c ENDIF 1000 CONTINUE 1002 CONTINUE 1004 CONTINUE * VRTDI4I= (0.0,0.0) VRTDI4J= (0.0,0.0) VRTDI4m= (0.0,0.0) VRTDI4p= (0.0,0.0) * IF (PARA (LO, L) .EQ. 'ODABI ') THEN DO 3010 IVTORP = 1,9 DO 3012 IVTOR1 = 1,9 DO 3014 I = 1, 2 * N +1 VRTDI4P= VRTDI4P+ EGT(I,IVTOR1,IVTORP) & * (I - N - 0.5) & * 0.5 * (-A2T4(I,IVTOR1,IVTORP) & + A3T4(I,IVTOR1,IVTORP)) vrtdi4i=dreal(2.*VRTDI4p) 3014 CONTINUE 3012 CONTINUE 3010 CONTINUE ELSE IF (PARA (LO, L) .EQ. 'ODABJI') THEN DO 8110 IVTORP = 1,9 DO 8112 IVTOR1 = 1,9 DO 8114 I = 1, 2 * N+1 VRTDI4P= VRTDI4P+ EGT(I,IVTOR1,IVTORP) & * (I - N - 0.5) & *(N*(N+1)) & * 0.5 * (-A2T4(I,IVTOR1,IVTORP) & + A3T4(I,IVTOR1,IVTORP)) vrtdi4i=dreal(2.*VRTDI4p) 8114 CONTINUE 8112 CONTINUE 8110 CONTINUE ELSE IF (PARA (LO, L) .EQ. 'ODAB6I') THEN DO 7610 IVTORP = 1,9 DO 7612 IVTOR1 = 1,9 DO 7614 I = 1, 2 * N VRTDI4P= VRTDI4P+ EGT(I,IVTOR1,IVTORP) & * (I - N - 0.5) & * 0.5 * (-A20T4(I,IVTOR1,IVTORP) & + A21T4(I,IVTOR1,IVTORP)) vrtdi4i=dreal(2.*VRTDI4p) 7614 CONTINUE 7612 CONTINUE 7610 CONTINUE ELSE IF (PARA (LO, L) .EQ. 'DACI ') THEN DO 7940 IVTORP = 1,9 DO 7942 IVTOR1 = 1,9 DO 7944 I = 1, 2 * N+1 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) cik debug 19 march02, the (-) sign is taken into account here but the c multplication by "i" to make the derivative real is taken into account c inside VSET like the other imaginary parameters VRTDI4p= VRTDI4p+ EGT(I,IVTOR1,IVTORP) & * (I - N - 0.5) & *(A1T4(I,IVTOR1,IVTORP))*((0.,-1.)) vrtdi4m=vrtdi4m & +EGTM(I,IVTOR1,IVTORP)*(I-N-1.5)*A1T4M(I,IVTOR1,IVTORP) & *((0.,1.)) vrtdi4j=vrtdi4p+vrtdi4m c if(N.EQ.2.and.isig.eq.0) then c print*,'egt=',egt(I,IVTOR1,IVTORP) c 1,'A1T4=',A1T4(I,IVTOR1,IVTORP),'I=',I,'K=',I-N-1,'IVTOR1=', c 2IVTOR1,'IVTORP=',IVTORP,'EGTM=',EGTM(I,IVTOR1,IVTORP) c 3,'A1T4M=',A1T4M(I,IVTOR1,IVTORP) vrtdi4i=dreal(2.*VRTDI4p) c print*,'vrtid4p=',vrtdi4p,'vrtdi4m=',vrtdi4m,'vrtdi4j=',VRTDI4j c 1,'vrtdi4i=',vrtdi4i c endif 7944 CONTINUE 7942 CONTINUE 7940 CONTINUE ELSE IF (PARA (LO, L) .EQ. 'DACJI ') THEN DO 9140 IVTORP = 1,9 DO 9142 IVTOR1 = 1,9 DO 9144 I = 1, 2 * N +1 VRTDI4P= VRTDI4P+ EGT(I,IVTOR1,IVTORP) & * (I - N - 0.5) & *(N*(N+1)) & *A1T4(I,IVTOR1,IVTORP)*((0.,-1.)) vrtdi4m=vrtdi4m & +EGTM(I,IVTOR1,IVTORP)*(I-N-1.5)*A1T4M(I,IVTOR1,IVTORP) & *((0.,1.))*(N*(N+1)) vrtdi4j=vrtdi4p+vrtdi4m vrtdi4i=dreal(2.*VRTDI4p) 9144 CONTINUE 9142 CONTINUE 9140 CONTINUE ELSE IF (PARA (LO, L) .EQ. 'ODACI ') THEN DO 7540 IVTORP = 1,9 DO 7542 IVTOR1 = 1,9 DO 7544 I = 1, 2 * N+1 VRTDI4p= VRTDI4p+ EGT(I,IVTOR1,IVTORP) & * (I - N - 0.5)*(0.,-1.) & *(A1T4(I,IVTOR1,IVTORP)- & 0.5 * (A2T4(I,IVTOR1,IVTORP) & + A3T4(I,IVTOR1,IVTORP))) vrtdi4m=vrtdi4m & +EGTM(I,IVTOR1,IVTORP)*(I-N-1.5)*(0.,1.) & *(A1T4M(I,IVTOR1,IVTORP)-0.5*(A2T4M(I,IVTOR1,IVTORP) & +A3T4M(I,IVTOR1,IVTORP))) vrtdi4j=vrtdi4p+vrtdi4m vrtdi4i=dreal(2.*VRTDI4p) if(N.EQ.2.and.isig.eq.0) then print*,'egt=',egt(I,IVTOR1,IVTORP) 1,'A1T4=',A1T4(I,IVTOR1,IVTORP),'I=',I,'K=',I-N-1,'IVTOR1=', 2IVTOR1,'IVTORP=',IVTORP,'EGTM=',EGTM(I,IVTOR1,IVTORP) 3,'A1T4M=',A1T4M(I,IVTOR1,IVTORP) 4,'A2T4=',A2T4(I,IVTOR1,IVTORP),'A2T4M=',A2T4M(I,IVTOR1,IVTORP) 5,'A3T4=',A3T4(I,IVTOR1,IVTORP),'A3T4M=',A3T4M(I,IVTOR1,IVTORP) print*,'vrtid4p=',vrtdi4p,'vrtdi4m=',vrtdi4m,'vrtdi4i=',VRTDI4I endif 7544 CONTINUE 7542 CONTINUE 7540 CONTINUE cc ELSE IF (PARA (LO, L) .EQ. 'DAC12 ') THEN cc DO 3140 IVTORP = 1,9 cc DO 3142 IVTOR1 = 1,9 cc DO 3144 I = 1, 2 * N cc VRTDI4I= VRTDI4I+ EGT(I,IVTOR1,IVTORP) cc & * (I - N - 0.5) cc & *(A1T1(I,IVTOR1,IVTORP)-0.5 cc & * (A3T4B(I,IVTOR1,IVTORP) + A4T4B(I,IVTOR1,IVTORP))) c3144 CONTINUE c3142 CONTINUE c3140 CONTINUE ENDIF * END C******************************************************************** FUNCTION VRTDI5 (L, LO) 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 1,NN=(30)+1,ISIGMA=(2)) COMMON/EIGEN/HR(NDMX,NDMX),HI(NDMX,NDMX),WORK(NDMX), *EGVC3R(KDMX,9),EGVC3I(KDMX,9),NBR(2),VECTPR(10,961,KDMX,9) *,VECTPI(10,961,KDMX,9) COMMON / CHARA / PARA (2,160), PR, PROBS (2,20000), REF (20000) COMMON/QUANT/ISIG,IV,N,KK,IISIG complex(8) YCONJ,Y,VRTDI5 * complex(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) & ,A1T4M(KDMX,9,9) & ,A2T4M(KDMX,9,9),A3T4M(KDMX,9,9),A1T2M(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 & ,A1T4M,A2T4M,A3T4M,A1T2M * complex(8) EGT(KDMX,9,9) complex(8) VRTDIA,VRTDIB,VRTDIC,VRTDID,VRTDIE,VRTDIF complex(8) VRTDIZ,VRTDIZ1,VRTDIQ,VRTDIQ2,VRTDIG,VRTDIY complex(8) VRTDIY2,VRTDIX,VRTDIX1,VRTDIH,VRTDIJ,VRTDIJ1 complex(8) VRTDIU,VRTDIK,VRTDIK3,VRTDIK4,VRTDIL,VRTDIM complex(8) VRTDIW,VRTDIN,VRTDIO,VRTDIP * C PRINT*,'DANS VRRTDI5' DO 1004 IVTORP = 1,9 DO 1002 IVTOR1 = 1,9 DO 1000 I = 1, 2 * N + 1 YCONJ=dcmplx(EGVC3R(I,IVTORP),-EGVC3I(I,IVTORP)) Y=dcmplx(EGVC3R(I,IVTOR1),EGVC3I(I,IVTOR1)) c EGT(I,IVTOR1,IVTORP) = EGVC3(I,IVTORP) * EGVC3(I,IVTOR1) EGT(I,IVTOR1,IVTORP) = YCONJ*Y 1000 CONTINUE 1002 CONTINUE 1004 CONTINUE * IF (PARA(LO,L).EQ.'FV ' .OR. PARA(LO,L).EQ.'OFV ') THEN VRTDIA = (0.0,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,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,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,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,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,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,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,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,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,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,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,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,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,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,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,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,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,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,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,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,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.'V12K ')THEN VRTDIK4=(0.0,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,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,0.0) VRTDIU = (0.0,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,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,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,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,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.'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 VRTDI5I (L, LO) 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 1,NN=(30)+1,ISIGMA=(2)) COMMON/EIGEN/HR(NDMX,NDMX),HI(NDMX,NDMX),WORK(NDMX), *EGVC3R(KDMX,9),EGVC3I(KDMX,9),NBR(2),VECTPR(10,961,KDMX,9) *,VECTPI(10,961,KDMX,9) COMMON / CHARA / PARA (2,160), PR, PROBS (2,20000), REF (20000) COMMON/QUANT/ISIG,IV,N,KK,IISIG complex(8) YCONJ,Y,VRTDI5I * complex(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) & ,A1T4M(KDMX,9,9) & ,A2T4M(KDMX,9,9),A3T4M(KDMX,9,9),A1T2M(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 & ,A1T4M,A2T4M,A3T4M,A1T2M * complex(8) EGT(KDMX,9,9) complex(8) VRTDIA,VRTDIH,VRTDIJ,VRTDIV,VRTDIK,VRTDIK3 complex(8) VRTDIK4,VRTDIL,VRTDIN * C PRINT*,'DANS VRRTDI5' DO 1004 IVTORP = 1,9 DO 1002 IVTOR1 = 1,9 DO 1000 I = 1, 2 * N + 1 YCONJ=dcmplx(EGVC3R(I,IVTORP),-EGVC3I(I,IVTORP)) Y=dcmplx(EGVC3R(I,IVTOR1),EGVC3I(I,IVTOR1)) c EGT(I,IVTOR1,IVTORP) = EGVC3(I,IVTORP) * EGVC3(I,IVTOR1) EGT(I,IVTOR1,IVTORP) = YCONJ*Y 1000 CONTINUE 1002 CONTINUE 1004 CONTINUE * IF (PARA(LO,L).EQ.'FVI ' .OR. PARA(LO,L).EQ.'OFVI ') THEN VRTDIA = (0.0,0.0) DO 7016 IVTORP = 1,9 DO 7014 IVTOR1 = 1,9 DO 7013 I = 1, 2 * N + 1 VRTDIA = VRTDIA + EGT(I,IVTOR1,IVTORP) & *(-0.5*A7T5(I,IVTOR1,IVTORP) & + 0.5*A1T5(I,IVTOR1,IVTORP)) 7013 CONTINUE 7014 CONTINUE 7016 CONTINUE END IF * IF (PARA(LO,L).EQ.'AK5I ' .OR. PARA(LO,L).EQ.'AK5JI ') THEN VRTDIH =(0.0,0.0) DO 7184 IVTORP = 1,9 DO 7183 IVTOR1 = 1,9 DO 7182 I = 1, 2 * N + 1 K = I - N - 1 VRTDIH = VRTDIH + EGT(I,IVTOR1,IVTORP) * K * K & *(-0.5*A7T5(I,IVTOR1,IVTORP) & + 0.5*A1T5(I,IVTOR1,IVTORP)) 7182 CONTINUE 7183 CONTINUE 7184 CONTINUE END IF * IF (PARA(LO,L).EQ.'AK7I '.OR.PARA(LO,L).EQ.'AK7JI ')THEN VRTDIJ =(0.0,0.0) DO 7172 IVTORP = 1,9 DO 7171 IVTOR1 = 1,9 DO 7170 I = 1, 2 * N + 1 K = I - N - 1 VRTDIJ = VRTDIJ + EGT(I,IVTOR1,IVTORP) & *(+ 0.5*A10T5(I,IVTOR1,IVTORP) & - 0.5*A11T5(I,IVTOR1,IVTORP) & - 0.5*A16T5(I,IVTOR1,IVTORP) & + 0.5*A17T5(I,IVTOR1,IVTORP)) 7170 CONTINUE 7171 CONTINUE 7172 CONTINUE END IF * IF (PARA(LO,L).EQ.'AK7KI ') THEN VRTDIV = (0.0,0.0) DO 8152 IVTORP = 1,9 DO 8151 IVTOR1 = 1,9 DO 8150 I = 1, 2 * N + 1 K = I - N - 1 VRTDIV = VRTDIV + EGT(I,IVTOR1,IVTORP)*K**2 & *(+ 0.5*A10T5(I,IVTOR1,IVTORP) & - 0.5*A11T5(I,IVTOR1,IVTORP) & - 0.5*A16T5(I,IVTOR1,IVTORP) & + 0.5*A17T5(I,IVTOR1,IVTORP)) 8150 CONTINUE 8151 CONTINUE 8152 CONTINUE ENDIF * IF (PARA(LO,L).EQ.'ANVI '.OR.PARA(LO,L).EQ.'ANVJI ') THEN VRTDIK = (0.0,0.0) DO 7312 IVTORP = 1,9 DO 7311 IVTOR1 = 1,9 DO 7310 I = 1, 2 * N + 1 VRTDIK = VRTDIK + EGT(I,IVTOR1,IVTORP) & *(+ 0.5*A12T5(I,IVTOR1,IVTORP) & - 0.5*A13T5(I,IVTOR1,IVTORP)) 7310 CONTINUE 7311 CONTINUE 7312 CONTINUE END IF * IF (PARA(LO,L).EQ.'BK2I '.OR.PARA(LO,L).EQ.'BK2JI ') THEN VRTDIL = (0.0,0.0) DO 7418 IVTORP = 1,9 DO 7417 IVTOR1 = 1,9 DO 7416 I = 1, 2 * N + 1 K = I - N - 1 VRTDIL = VRTDIL + EGT(I,IVTOR1,IVTORP) * K * K & *(0.5*A12T5(I,IVTOR1,IVTORP) & - 0.5*A13T5(I,IVTOR1,IVTORP)) 7416 CONTINUE 7417 CONTINUE 7418 CONTINUE END IF * IF (PARA(LO,L).EQ.'AK5KI ') THEN VRTDIN =(0.0,0.0) DO 7746 IVTORP = 1,9 DO 7745 IVTOR1 = 1,9 DO 7744 I = 1, 2 * N + 1 K = I - N - 1 VRTDIN = VRTDIN + EGT(I,IVTOR1,IVTORP) * K * K * K * K & *( - 0.5*A7T5(I,IVTOR1,IVTORP) & + 0.5*A1T5(I,IVTOR1,IVTORP)) 7744 CONTINUE 7745 CONTINUE 7746 CONTINUE END IF * IF (PARA(LO,L).EQ.'V12JI ')THEN VRTDIK3= (0.0,0.0) DO 4412 IVTORP = 1,9 DO 4411 IVTOR1 = 1,9 DO 4410 I = 1, 2 * N + 1 VRTDIK3= VRTDIK3+ EGT(I,IVTOR1,IVTORP) & *(0.5*A18T5(I,IVTOR1,IVTORP) & - 0.5*A19T5(I,IVTOR1,IVTORP)) 4410 CONTINUE 4411 CONTINUE 4412 CONTINUE END IF * IF (PARA(LO,L).EQ.'V12KI ')THEN VRTDIK4=(0.0,0.0) DO 4615 IVTORP = 1,9 DO 4614 IVTOR1 = 1,9 DO 4613 I = 1, 2 * N + 1 K = I - N - 1 VRTDIK4= VRTDIK4+ EGT(I,IVTOR1,IVTORP) & *( 0.5*A18T5(I,IVTOR1,IVTORP) & - 0.5*A19T5(I,IVTOR1,IVTORP)) & *(K**2) 4613 CONTINUE 4614 CONTINUE 4615 CONTINUE END IF * IF (PARA(LO,L).EQ.'FVI ') THEN VRTDI5I= VRTDIA * N*(N+1) ELSE IF (PARA(LO,L).EQ.'ANVI ') THEN VRTDI5I= VRTDIK * N*(N+1) ELSE IF (PARA(LO,L).EQ.'V12JI ') THEN VRTDI5I= VRTDIK3* N*(N+1) ELSE IF (PARA(LO,L).EQ.'V12KI ') THEN VRTDI5I= VRTDIK4 ELSE IF (PARA(LO,L).EQ.'ANVJI ') THEN VRTDI5I= VRTDIK * N*(N+1)*N*(N+1) ELSE IF (PARA(LO,L).EQ.'BK2I ') THEN VRTDI5I = VRTDIL ELSE IF (PARA(LO,L).EQ.'BK2JI ') THEN VRTDI5I= VRTDIL*N*(N+1) ELSE IF (PARA(LO,L).EQ.'OFVI ') THEN VRTDI5I= VRTDIA * N*(N+1) * N*(N+1) ELSE IF (PARA(LO,L).EQ.'AK5I ') THEN VRTDI5I= VRTDIH ELSE IF (PARA(LO,L).EQ.'AK7I ') THEN VRTDI5I= VRTDIJ ELSE IF (PARA(LO,L).EQ.'AK5JI ') THEN VRTDI5I= VRTDIH * N*(N+1) ELSE IF (PARA(LO,L).EQ.'AK5KI ') THEN VRTDI5I= VRTDIN ELSE IF (PARA(LO,L).EQ.'AK7KI ') THEN VRTDI5I= VRTDIV ELSE IF (PARA(LO,L).EQ.'AK7JI ') THEN VRTDI5I= VRTDIJ*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*834 CHARACTER*1 PR,PROBS CHARACTER*6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1 1,NN=(30)+1,ISIGMA=(2)) COMMON/EIGEN/HR(NDMX,NDMX),HI(NDMX,NDMX),WORK(NDMX), *EGVC3R(KDMX,9),EGVC3I(KDMX,9),NBR(2),VECTPR(10,961,KDMX,9) *,VECTPI(10,961,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/SYMB/ABC COMMON/CHARA/PARA(2,160),PR,PROBS(2,20000),REF(20000) COMMON/QUANT/ISIG,IV,N,KK,IISIG DIMENSION CST(2,139) complex(8) A(9,NTORMX,2*KDMX,NN,ISIGMA) complex(8) YCONJ,Y RHO=CST(LO,128) F=CST(LO,127) V3=CST(LO,129) V6=CST(LO,130) V9=CST(LO,131) V12=CST(LO,132) RHORHO=CST(LO,134) 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 NP1=N+1 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,NP1,IISIG)*A(IVTORP,III+1,I,NP1,IISIG) & *(RHOKSG+RHOKS1) ENDIF A1=A1+A(IVTORP,III,I,NP1,IISIG)*A(IVTORP,III,I,NP1,IISIG) &*RHOKSG A2=A2+A(IVTORP,III,I,NP1,IISIG)*A(IVTORP,III,I,NP1,IISIG) &*RHOKSG*RHOKSG A3=A3+A(IVTORP,III,I,NP1,IISIG)*A(IVTORP,III,I,NP1,IISIG) &*RHOKSG*RHOKSG & *RHOKSG 8 CONTINUE c EG=EGVC3(I,IVTORP)**2 Y=dcmplx(EGVC3R(I,IVTORP),EGVC3I(I,IVTORP)) YCONJ=dcmplx(EGVC3R(I,IVTORP),-EGVC3I(I,IVTORP)) EG=Y*YCONJ 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,NP1,IISIG) & *A(IVTOR1,III,IPLUS2,NP1,IISIG) & *(K*RHOKSG +(K+2)*RHOKS1 ) A2=A2+A(IVTORP,III,I,NP1,IISIG) & *A(IVTOR1,III,IPLUS2,NP1,IISIG) & *(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) YCONJ=dcmplx(EGVC3R(I,IVTORP),-EGVC3I(I,IVTORP)) Y=dcmplx(EGVC3R(IPLUS2,IVTOR1),EGVC3I(IPLUS2,IVTOR1)) c VRTDIB =VRTDIB +EGVC3(I,IVTORP)*EGVC3(IPLUS2,IVTOR1 ) VRTDIB =VRTDIB +YCONJ*Y * *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,VR,VI,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*834 CHARACTER*6 PARA,REF CHARACTER*1 PROBS CHARACTER*1 PR PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1 1,NN=(30)+1,ISIGMA=(2)) COMMON/EIGEN/HR(NDMX,NDMX),HI(NDMX,NDMX),WORK(NDMX), *EGVC3R(KDMX,9),EGVC3I(KDMX,9),NBR(2),VECTPR(10,961,KDMX,9) *,VECTPI(10,961,KDMX,9) COMMON/EIGEN1/EGVL(2*NDMX),EGVC(NDMX,2*NDMX) *,EGVCR(NDMX,2*NDMX),EGVCI(NDMX,2*NDMX) COMMON/TOR/A(9,NTORMX,2*KDMX,NN,ISIGMA),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/DERIVR(10,961,80),ENER(10,961),DERIVI(10,961,80) COMMON/CHARA/PARA(2,160),PR,PROBS(2,20000),REF(20000) COMMON/EXPDAT / ETRANS(20000),IVOBS(2,20000), * NOBS(2,20000),KOBS(2,20000),IBLK(2,20000),IW(20000),W(20000), * NDATA,NADAT,EPSI,NOFIT,NFITMW,NFITIR,NFIMW0 ,NFIMW1 ,NITT, * IAST(20000),NFI004 ,NFI080 ,NFI100 ,NFI020 ,NFI200 ,NFI045 , & NGST0 ,NFI010 ,SW070,NFI070 ,NFIMW2,IKAKC,JMAX,NFI1M0, & NFIR10,NFIR21,NFIR32,NFIMW3,NFIMW4,SWA,SWE,NFITMWA,NFITMWE &,INT COMMON/SYMB/ABC COMMON/QUANT/ISIG,IV,N,KK,IISIG DIMENSION CST(2,139),IBLSTO(2) complex(8) VR(160),VI(160) complex(8) A * complex(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) * complex(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) & ,A1T4M(KDMX,9,9) & ,A2T4M(KDMX,9,9),A3T4M(KDMX,9,9),A1T2M(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 & ,A1T4M,A2T4M,A3T4M,A1T2M complex(8) AAA,AA2,AA4,AA5,AA5B,VRTDI1,VRTDI2,VRTDI2I complex(8) VRTDI4,VRTDI4I,VRTDI5,VRTDI5I,VTORS DIMENSION VRT4I(160,2) * 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 * NP1=N+1 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,128) F=CST(LO,127) V3=CST(LO,129) V3I=CST(LO,133) V6=CST(LO,130) V9=CST(LO,131) V12=CST(LO,132) RHORHO=CST(LO,134) DO 50 IVTORP = 1,9 DO 60 IVTOR1 = 1,9 DO 70 I = 1, 2 * N + 1 A1T1(I,IVTOR1,IVTORP) = (0.0,0.0) A1T2(I,IVTOR1,IVTORP) = (0.0,0.0) A1T2M(I,IVTOR1,IVTORP) = (0.0,0.0) A2T2(I,IVTOR1,IVTORP) = (0.0,0.0) A3T2(I,IVTOR1,IVTORP) = (0.0,0.0) A4T2(I,IVTOR1,IVTORP) = (0.0,0.0) A4T2B(I,IVTOR1,IVTORP) = (0.0,0.0) A5T2(I,IVTOR1,IVTORP) = (0.0,0.0) A5T2B(I,IVTOR1,IVTORP) = (0.0,0.0) A7T2(I,IVTOR1,IVTORP) = (0.0,0.0) A8T2(I,IVTOR1,IVTORP) = (0.0,0.0) A9T2(I,IVTOR1,IVTORP) = (0.0,0.0) A10T2(I,IVTOR1,IVTORP) = (0.0,0.0) A11T2(I,IVTOR1,IVTORP) = (0.0,0.0) A1T4(I,IVTOR1,IVTORP) = (0.0,0.0) A1T4M(I,IVTOR1,IVTORP) = (0.0,0.0) A1T4B(I,IVTOR1,IVTORP) = (0.0,0.0) A2T4(I,IVTOR1,IVTORP) = (0.0,0.0) A2T4M(I,IVTOR1,IVTORP) = (0.0,0.0) A3T4(I,IVTOR1,IVTORP) = (0.0,0.0) A3T4M(I,IVTOR1,IVTORP) = (0.0,0.0) A3T4B(I,IVTOR1,IVTORP) = (0.0,0.0) A4T4(I,IVTOR1,IVTORP) = (0.0,0.0) A4T4B(I,IVTOR1,IVTORP) = (0.0,0.0) A5T4(I,IVTOR1,IVTORP) = (0.0,0.0) A5T4B(I,IVTOR1,IVTORP) = (0.0,0.0) A6T4(I,IVTOR1,IVTORP) = (0.0,0.0) A6T4B(I,IVTOR1,IVTORP) = (0.0,0.0) A20T4(I,IVTOR1,IVTORP) = (0.0,0.0) A21T4(I,IVTOR1,IVTORP) = (0.0,0.0) A1T5(I,IVTOR1,IVTORP) = (0.0,0.0) A2T5(I,IVTOR1,IVTORP) = (0.0,0.0) A3T5(I,IVTOR1,IVTORP) = (0.0,0.0) A4T5(I,IVTOR1,IVTORP) = (0.0,0.0) A4T5B(I,IVTOR1,IVTORP) = (0.0,0.0) A4T5BB(I,IVTOR1,IVTORP) = (0.0,0.0) A5T5(I,IVTOR1,IVTORP) = (0.0,0.0) A5T5B(I,IVTOR1,IVTORP) = (0.0,0.0) A5T5BB(I,IVTOR1,IVTORP) = (0.0,0.0) A7T5(I,IVTOR1,IVTORP) = (0.0,0.0) A8T5(I,IVTOR1,IVTORP) = (0.0,0.0) A8T5B(I,IVTOR1,IVTORP) = (0.0,0.0) A9T5(I,IVTOR1,IVTORP) = (0.0,0.0) A9T5B(I,IVTOR1,IVTORP) = (0.0,0.0) A10T5(I,IVTOR1,IVTORP) = (0.0,0.0) A10T5B(I,IVTOR1,IVTORP) = (0.0,0.0) A11T5(I,IVTOR1,IVTORP) = (0.0,0.0) A11T5B(I,IVTOR1,IVTORP) = (0.0,0.0) A12T5(I,IVTOR1,IVTORP) = (0.0,0.0) A13T5(I,IVTOR1,IVTORP) = (0.0,0.0) A14T5(I,IVTOR1,IVTORP) = (0.0,0.0) A14T5B(I,IVTOR1,IVTORP) = (0.0,0.0) A15T5(I,IVTOR1,IVTORP) = (0.0,0.0) A15T5B(I,IVTOR1,IVTORP) = (0.0,0.0) A16T5(I,IVTOR1,IVTORP) = (0.0,0.0) A16T5B(I,IVTOR1,IVTORP) = (0.0,0.0) A17T5(I,IVTOR1,IVTORP) = (0.0,0.0) A17T5B(I,IVTOR1,IVTORP) = (0.0,0.0) A18T5(I,IVTOR1,IVTORP) = (0.0,0.0) A19T5(I,IVTOR1,IVTORP) = (0.0,0.0) A1TS(I,IVTOR1,IVTORP) = (0.0,0.0) A2TS(I,IVTOR1,IVTORP) = (0.0,0.0) A5TS(I,IVTOR1,IVTORP) = (0.0,0.0) A6TS(I,IVTOR1,IVTORP) = (0.0,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 = dconjg(A(IVTORP,III,M-1+I,NP1,IISIG)) & *A(IVTOR1,III,M-1+I,NP1,IISIG) * Pour VRTDI1 A1T1(I,IVTOR1,IVTORP) = A1T1(I,IVTOR1,IVTORP) + AAA * Pour VRTDI2 AA2 = dconjg(A(IVTORP,III,M-1+I,NP1,IISIG)) & *A(IVTOR1,III,M+I+1,NP1,IISIG) c AA2M= dconjg(A(IVTORP,III,M-1+I,NP1,IISIG)) c & *A(IVTOR1,III,M+I-1-2,NP1,IISIG) A1T2(I,IVTOR1,IVTORP) = A1T2(I,IVTOR1,IVTORP) + AA2 c A1T2M(I,IVTOR1,IVTORP) = A1T2M(I,IVTOR1,IVTORP) + AA2M 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 = dconjg(A(IVTORP,III,M-1+I,NP1,IISIG)) & *A(IVTOR1,III,M+I,NP1,IISIG) if(i.gt.1)then AA4M= dconjg(A(IVTORP,III,M-1+I,NP1,IISIG)) & *A(IVTOR1,III,M+I-2,NP1,IISIG) A1T4M(I,IVTOR1,IVTORP)=A1T4M(I,IVTOR1,IVTORP) + AA4M endif 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) & + dconjg(A(IVTORP,III+1,M-1+I,NP1,IISIG)) & *A(IVTOR1,III,M+I+1,NP1,IISIG) A5T2(I,IVTOR1,IVTORP) = A5T2(I,IVTOR1,IVTORP) & + dconjg(A(IVTORP,III,M-1+I,NP1,IISIG)) & *A(IVTOR1,III+1,M+I+1,NP1,IISIG) * Pour VRTDI4 A2T4(I,IVTOR1,IVTORP) = A2T4(I,IVTOR1,IVTORP) & + dconjg(A(IVTORP,III+1,M-1+I,NP1,IISIG)) & *A(IVTOR1,III,M+I,NP1,IISIG) if(i.gt.1)then A2T4M(I,IVTOR1,IVTORP) = A2T4M(I,IVTOR1,IVTORP) & + dconjg(A(IVTORP,III+1,M-1+I,NP1,IISIG)) & *A(IVTOR1,III,M+I-2,NP1,IISIG) A3T4M(I,IVTOR1,IVTORP) = A3T4M(I,IVTOR1,IVTORP) & + dconjg(A(IVTORP,III,M-1+I,NP1,IISIG)) & *A(IVTOR1,III+1,M+I-2,NP1,IISIG) endif A3T4(I,IVTOR1,IVTORP) = A3T4(I,IVTOR1,IVTORP) & + dconjg(A(IVTORP,III,M-1+I,NP1,IISIG)) & *A(IVTOR1,III+1,M+I,NP1,IISIG) * Pour VRTDI5 AA5 = dconjg(A(IVTORP,III,M-1+I,NP1,IISIG)) & *A(IVTOR1,III+1,M-1+I,NP1,IISIG) 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) & + dconjg(A(IVTORP,III+2,M-1+I,NP1,IISIG)) & *A(IVTOR1,III,M+I+1,NP1,IISIG) A9T2(I,IVTOR1,IVTORP) = A9T2(I,IVTOR1,IVTORP) & + dconjg(A(IVTORP,III,M-1+I,NP1,IISIG)) & *A(IVTOR1,III+2,M+I+1,NP1,IISIG) * Pour VRTDI4 A20T4(I,IVTOR1,IVTORP) = A20T4(I,IVTOR1,IVTORP) & + dconjg(A(IVTORP,III+2,M-1+I,NP1,IISIG)) & *A(IVTOR1,III,M+I,NP1,IISIG) A21T4(I,IVTOR1,IVTORP) = A21T4(I,IVTOR1,IVTORP) & + dconjg(A(IVTORP,III,M-1+I,NP1,IISIG)) & *A(IVTOR1,III+2,M+I,NP1,IISIG) 190 CONTINUE DO 150 III = 2, NDIMTO * Pour VRTDI4 A4T4(I,IVTOR1,IVTORP) = A4T4(I,IVTOR1,IVTORP) & + dconjg(A(IVTORP,III,M-1+I,NP1,IISIG)) & *A(IVTOR1,III-1,M+I,NP1,IISIG) * Pour VRTDI5 AA5 = dconjg(A(IVTORP,III,M-1+I,NP1,IISIG)) & *A(IVTOR1,III-1,M-1+I,NP1,IISIG) 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) & + dconjg(A(IVTORP,III,M-1+I,NP1,IISIG)) & *A(IVTOR1,III+2,M-1+I,NP1,IISIG) AA5B= dconjg(A(IVTORP,III,M-1+I,NP1,IISIG)) & *A(IVTOR1,III+2,M-1+I,NP1,IISIG) 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) & + dconjg(A(IVTORP,III,M-1+I,NP1,IISIG)) & *A(IVTOR1,III+4,M-1+I,NP1,IISIG) * 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,NP1,IISIG)*A(IVTOR1,III+4,M+I,NP1,IISIG) * 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,NP1,IISIG)*A(IVTOR1,III,M+I+1,NP1,IISIG) C A5T2B(I,IVTOR1,IVTORP) = A5T2B(I,IVTOR1,IVTORP) C & + A(IVTORP,III,M-1+I,NP1,IISIG)*A(IVTOR1,III+4,M+I+1,NP1,IISIG) C * 260 CONTINUE DO 270 III = 5, NDIMTO A19T5(I,IVTOR1,IVTORP) = A19T5(I,IVTOR1,IVTORP) & + dconjg(A(IVTORP,III,M-1+I,NP1,IISIG)) & *A(IVTOR1,III-4,M-1+I,NP1,IISIG) * 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 * Pour VRTDI5 DO 170 III = 3, NDIMTO A13T5(I,IVTOR1,IVTORP) = A13T5(I,IVTOR1,IVTORP) & + dconjg(A(IVTORP,III,M-1+I,NP1,IISIG)) & *A(IVTOR1,III-2,M-1+I,NP1,IISIG) A10T5B(I,IVTOR1,IVTORP) = A10T5B(I,IVTOR1,IVTORP) & + dconjg(A(IVTORP,III,M-1+I,NP1,IISIG)) & *A(IVTOR1,III-2,M-1+I,NP1,IISIG) & * R5A(III,I) A17T5B(I,IVTOR1,IVTORP) = A17T5B(I,IVTOR1,IVTORP) & + dconjg(A(IVTORP,III,M-1+I,NP1,IISIG)) & *A(IVTOR1,III-2,M-1+I,NP1,IISIG) & * R5GG(III,I) * C FOR DAC9: III-3; FOR DAC12 III-4 if(iii.ne.3)then A4T4B(I,IVTOR1,IVTORP) = A4T4B(I,IVTOR1,IVTORP) & + dconjg(A(IVTORP,III,M-1+I,NP1,IISIG)) & *A(IVTOR1,III-3,M+I,NP1,IISIG) endif 170 CONTINUE * Pour VTORS DO 180 III = 1, NDIMTO-3 A5TS(I,IVTOR1,IVTORP) = A5TS(I,IVTOR1,IVTORP) & + dconjg(A(IVTORP,III,M-1+I,NP1,IISIG)) & *A(IVTOR1,III+3,M-1+I,NP1,IISIG) * C FOR SIN 12 alpha :III+4 C FOR sin9 alpha :III+3 A3T4B(I,IVTOR1,IVTORP) = A3T4B(I,IVTOR1,IVTORP) & + dconjg(A(IVTORP,III,M-1+I,NP1,IISIG)) & *A(IVTOR1,III+3,M+I,NP1,IISIG) * C A4T2B and A5T2B for DBC12 :sin12 alpha commented out A4T2B(I,IVTOR1,IVTORP) = A4T2B(I,IVTOR1,IVTORP) & + dconjg(A(IVTORP,III+3,M-1+I,NP1,IISIG)) & *A(IVTOR1,III,M+I+1,NP1,IISIG) A5T2B(I,IVTOR1,IVTORP) = A5T2B(I,IVTOR1,IVTORP) & + dconjg(A(IVTORP,III,M-1+I,NP1,IISIG)) & *A(IVTOR1,III+3,M+I+1,NP1,IISIG) C * 180 CONTINUE DO 280 III = 1, NDIMTO-4 A6TS(I,IVTOR1,IVTORP) = A6TS(I,IVTOR1,IVTORP) & + dconjg(A(IVTORP,III,M-1+I,NP1,IISIG)) & *A(IVTOR1,III+4,M-1+I,NP1,IISIG) 280 CONTINUE 120 CONTINUE 110 CONTINUE 100 CONTINUE * DO 1000 L=NA,NB C PRINT*,'PARA DANS VSET=',PARA(LO,L) VR(L)=(0.0,0.0) VI(L)=(0.0,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 VR(L)=VR(L)+VRTDI1(L,LO) c VR(L)=dreal(VR(L)) ELSE IF(PARA(LO,L).EQ.'B '.OR.PARA(LO,L).EQ.'C ')THEN VR(L)=VR(L)+VRTDI1(L,LO)+VRTDI2(L,LO) c if(N.EQ.2.AND.ISIG.EQ.0) print*,'vrtdi1=',vrtdi1(L,LO), c 1'vrtdi2=',vrtdi2(L,LO) c VR(L)=dreal(VR(L)) 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.'DAC '.OR.PARA(LO,L).EQ.'ODELTA'.OR. & PARA(LO,L).EQ.'DACJ '.OR.PARA(LO,L).EQ.'ODABJ '.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.'DELTA '.OR.PARA(LO,L).EQ.'ODAB6')THEN VR(L)=VR(L)+VRTDI4(L,LO) c VR(L)=dreal(VR(L)) c if(N.EQ.2.and.isig.eq.0) print*,'VR=',VR(L) ELSE IF(PARA(LO,L).EQ.'DACI '.OR.PARA(LO,L).EQ.'DACJI '.OR. & PARA(LO,L).EQ.'ODABI '.OR.PARA(LO,L).EQ.'ODABJI'.OR. & PARA(LO,L).EQ.'ODAB6I'.OR.PARA(LO,L).EQ.'ODACI ') THEN cikdebug 15 march 2002 cik debug 4 juin 2002: the derivatives must be real, for the deltaK=+-1 ccases I do this inside vrtdi4i, the deltaK=+1 and -1 imagninary parts are c cancelling each other, whereas the real parts are adding! VI(L)=VI(L)+VRTDI4I(L,LO) c if(N.EQ.2.and.isig.eq.0)print*,'VI(L)=',VI(L),'VR=',VR(L) c VI(L)=0.0 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.'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 ') THEN VR(L)=VR(L)+VRTDI2(L,LO) c VR(L)=dreal(VR(L)) ELSE IF(PARA(LO,L).EQ.'C2I '.OR.PARA(LO,L).EQ.'C2JI '.OR. & PARA(LO,L).EQ.'C2KI '.OR.PARA(LO,L).EQ.'C11I '.OR. & PARA(LO,L).EQ.'DBCI '.OR.PARA(LO,L).EQ.'ODBCI ')THEN VI(L)=VI(L)+VRTDI2I(L,LO)*(0.,1.) VI(L)=dreal(VI(L)) c if(N.EQ.2.AND.ISIG.EQ.0) print*,'VI=',VI(L) c VI(L)=0.0 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 ') THEN C PRINT*,'PARA BEFORE VRTDI5=',PARA(LO,L) VR(L)=VR(L)+VRTDI5(L,LO) c VR(L)=dreal(VR(L)) ELSE IF(PARA(LO,L).EQ.'FVI '.OR.PARA(LO,L).EQ.'OFVI '.OR. & PARA(LO,L).EQ.'AK5I '.OR.PARA(LO,L).EQ.'AK5JI '.OR. & PARA(LO,L).EQ.'AK5KI '.OR.PARA(LO,L).EQ.'ANVI '.OR. & PARA(LO,L).EQ.'ANVJI '.OR.PARA(LO,L).EQ.'BK2I '.OR. & PARA(LO,L).EQ.'BK2JI '.OR.PARA(LO,L).EQ.'AK7I '.OR. & PARA(LO,L).EQ.'AK7JI '.OR.PARA(LO,L).EQ.'AK7KI '.OR. & PARA(LO,L).EQ.'V12JI '.OR.PARA(LO,L).EQ.'V12KI ')THEN VI(L)=VI(L)+VRTDI5I(L,LO)*(0.,1.) VI(L)=dreal(VI(L)) c if(N.EQ.2.and.isig.EQ.0) print*,'V=',VI(L) c VI(L)=0.0 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 VR(L)=VR(L)+VTORS(L,CST,LO) c VR(L)=dreal(VR(L)) ELSEIF(PARA(LO,L).EQ.'V3I ') THEN VI(L)=VI(L)+VTORS(L,CST,LO)*(0.0,1.0) VI(L)=dreal(VI(L)) 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 c ELSE IF(PARA(LO,L).EQ.'RHO ') THEN c VR(L)=VR(L)+VTORS(L,CST,LO) c 1+VRTDI6(L,CST,LO,A(1,1,M)) ENDIF 1000 CONTINUE END C************************************************************* FUNCTION VTORS (L, CST, LO) 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 1,NN=(30)+1,ISIGMA=(2)) COMMON/EIGEN/HR(NDMX,NDMX),HI(NDMX,NDMX),WORK(NDMX), *EGVC3R(KDMX,9),EGVC3I(KDMX,9),NBR(2),VECTPR(10,961,KDMX,9) *,VECTPI(10,961,KDMX,9) COMMON / CHARA / PARA (2,160), PR, PROBS (2,20000), REF (20000) COMMON/QUANT/ISIG,IV,N,KK,IISIG complex(8) YCONJ,Y,VTORS REAL*8 CST(2,139) * complex(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) & ,A1T4M(KDMX,9,9) & ,A2T4M(KDMX,9,9),A3T4M(KDMX,9,9),A1T2M(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 & ,A1T4M,A2T4M,A3T4M,A1T2M * complex(8) EGT(KDMX,9,9) complex(8) VTORSA,VTORSB,VTORSC,VTORSD,VTORSE,VTORSF,VTORSI * F=CST(LO,127) * DO 1004 IVTORP = 1,9 DO 1002 IVTOR1 = 1,9 DO 1000 I = 1, 2 * N + 1 YCONJ=dcmplx(EGVC3R(I,IVTORP),-EGVC3I(I,IVTORP)) Y=dcmplx(EGVC3R(I,IVTOR1),EGVC3I(I,IVTOR1)) EGT(I,IVTOR1,IVTORP) = YCONJ*Y c 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,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,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,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. 'V3I ') THEN VTORSI = (0.0,0.0) DO 7082 IVTORP = 1,9 DO 7080 IVTOR1 = 1,9 DO 7088 I = 1, 2 * N + 1 VTORSI = VTORSI + EGT(I,IVTOR1,IVTORP) & * (A1T5(I,IVTOR1,IVTORP) - A7T5(I,IVTOR1,IVTORP)) & *0.5 7088 CONTINUE 7080 CONTINUE 7082 CONTINUE VTORS = VTORSI / 2. ELSE IF (PARA (LO, L) .EQ. 'V6 ') THEN VTORSD = (0.0,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,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,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(CR,CI,II,EGVL,KAFTER) 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 1,NN=(30)+1,ISIGMA=(2)) COMMON/QUANT/ISIG,IV,N,KK,IISIG COMMON/QUANT2/KKK(NDMX),NVT(NDMX),IPRITY(NDMX) DIMENSION CR(KDMX),KBEF(NDMX),CP(KDMX),EGVL(NDMX),KOLD(NDMX) DIMENSION KAFTER(NDMX),CI(KDMX) 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) c what should we do here? SUM=SUM+CR(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) IMPLICIT REAL*8 ( A-H,O-Z ) DIMENSION TERM(100) COMMON/QUANT/ISIG,IV,N,KK,IISIG 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) 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) RETURN END C*********************************************************** INTEGER FUNCTION IPOSA2(EGVCR,EGVCI,EGVL,A,EGVC4R,EGVC4I,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 1,NN=(30)+1,ISIGMA=(2)) COMMON/QUANT/ISIG,IV,N,KK,IISIG COMMON/QUANT2/KKK(NDMX),NVT(NDMX),IPRITY(NDMX) COMMON/C2C/PERC2L,PER23L(NDMX) COMMON/EIGEN/HR(NDMX,NDMX),HI(NDMX,NDMX),WORK(NDMX), *EGVC3R(KDMX,9),EGVC3I(KDMX,9),NBR(2),VECTPR(10,961,KDMX,9) *,VECTPI(10,961,KDMX,9) DIMENSION EGVCR(NDMX,NDMX),EGVL(NDMX) DIMENSION EGVCI(NDMX,NDMX) complex(8) PERC2L,PER23L complex(8) A(9,NTORMX,2*KDMX,NN,ISIGMA) DIMENSION EGVC4R(KDMX,NTORMX,NDMX) DIMENSION EGVC4I(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.2) THEN c WRITE (6,1083) IV,KK,EGVL(II),N,PR,IPR,II c print*,'PER23L=',PER23L(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,I3) RETURN END C********************************************************** INTEGER FUNCTION IPOSA(EGVCR,EGVCI,EGVL,A,EGVC4R,EGVC4I) 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 1,NN=(30)+1,ISIGMA=(2)) COMMON/QUANT/ISIG,IV,N,KK,IISIG COMMON/CHARA/PARA(2,160),PR,PROBS(2,20000),REF(20000) COMMON/ROTOR/NROTOR,NDIMTO COMMON/QUANT2/KKK(NDMX),NVT(NDMX),IPRITY(NDMX) COMMON/C2C/PERC2L,PER23L(NDMX) COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRON1 , * IBGTME,IBGVTD ,EVIB(2),IRMW,TERM COMMON/EIGEN/HR(NDMX,NDMX),HI(NDMX,NDMX),WORK(NDMX), *EGVC3R(KDMX,9),EGVC3I(KDMX,9),NBR(2),VECTPR(10,961,KDMX,9) *,VECTPI(10,961,KDMX,9) DIMENSION EGVCR(NDMX,NDMX),SUM(9),EGVCI(NDMX,NDMX), & EGVL(NDMX),KKC(NDMX),KKKU(NDMX),KKCU(NDMX), & KKKD(NDMX),KKCD(NDMX),NAUX(NDMX),NCHAR(NDMX) complex(8) A(9,NTORMX,2*KDMX,NN,ISIGMA) DIMENSION EGVC4R(KDMX,NTORMX,NDMX),EGVCV3R(KDMX),KAFTER(NDMX) DIMENSION EGVC4I(KDMX,NTORMX,NDMX),EGVCV3I(KDMX) complex(8) YCONJ,Y,Y2,YCONJ2,Y3,YCONJ3,Y4,YCONJ4 complex(8) YCONJM,YM,PER23L,PERC2L 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.0 DO 5 I=KT,2*N+KT C PRINT *, 'EGVCR',EGVCR(I,II) YCONJ=dcmplx(EGVCR(I,II),-EGVCI(I,II)) Y=dcmplx(EGVCR(I,II),EGVCI(I,II)) YY=dreal(YCONJ*Y) SUM(IKT)=SUM(IKT)+YY c 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+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.or.jjj.eq.1) 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) YCONJ2=dcmplx(EGVCR(LL,II),-EGVCI(LL,II)) Y2=dcmplx(EGVCR(LL,II),EGVCI(LL,II)) YY2=dreal(Y2*YCONJ2) IF (YY2.GT.XMAX) THEN c IF (EGVC(LL,II)*EGVC(LL,II).GT.XMAX) THEN XMAX=YY2 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 YCONJ3=dcmplx(EGVCR(II,JJ),-EGVCI(II,JJ)) Y3=dcmplx(EGVCR(II,JJ),EGVCI(II,JJ)) YY3=dreal(Y3*YCONJ3) YCONJM=dcmplx(EGVCR(MM,JJ),-EGVCI(MM,JJ)) YM=dcmplx(EGVCR(MM,JJ),EGVCI(MM,JJ)) YY3M=dreal(YCONJM*YM) c IF ((EGVC(II,JJ)**2+EGVC(MM,JJ)**2).GT.XMAX) THEN IF ((YY3+YY3M).GT.XMAX) THEN c XMAX=EGVC(II,JJ)**2+EGVC(MM,JJ)**2 XMAX=YY3+YY3M KKK(JJ)=IABS(M) END IF ELSE YCONJ4=dcmplx(EGVCR(II,JJ),-EGVCI(II,JJ)) Y4=dcmplx(EGVCR(II,JJ),EGVCI(II,JJ)) YY4=dreal(Y4*YCONJ4) c IF (EGVC(II,JJ)**2.GT.XMAX) THEN IF (YY4.GT.XMAX) THEN c XMAX=EGVC(II,JJ)**2 XMAX=YY4 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) EGVCV3R(IK)=EGVCR(I,II) EGVCV3I(IK)=EGVCI(I,II) 64 CONTINUE CALL WIGNER(EGVCV3R,EGVCV3I,II,EGVL,KAFTER) KKK(II)=KAFTER(II) ENDIF C PRINT*,'II=AVANT PARITY',II IF (N/2*2.EQ.N) THEN IF (KKC(II)/2*2.EQ.KKC(II)) THEN IPRITY(II)=1 ELSE IPRITY(II)=2 END IF ELSE IF (KKC(II)/2*2.NE.KKC(II)) THEN IPRITY(II)=1 ELSE IPRITY(II)=2 END IF END IF CALL PARITY(A,EGVC4R,EGVC4I,II) C PRINT*,'II APRES PARITY',II NIV=N+NVT(II) c IF(MOD(NIV,2).EQ.0) THEN c IF(REAL(PER23L(II)).GE.0.AND.AIMAG(PER23L(II)) c 1.GE.0.)THEN c IPRITY(II)=1 c ELSE c IPRITY(II)=2 c ENDIF c ELSE c IF(REAL(PER23L(II)).GE.0.AND.AIMAG(PER23L(II)) c 1.GE.0.)THEN c IPRITY(II)=2 c ELSE c IPRITY(II)=1 c ENDIF c 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.GT.2) THEN c WRITE (6,1083) IV,KK,EGVL(II),N,PR,IPR,II c print*,'PER23L=',PER23L(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,I3) RETURN END C************************************************************* C************************************************************* INTEGER FUNCTION IPOSE(EGVCR,EGVCI,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 1,NN=(30)+1,ISIGMA=(2)) COMMON/QUANT/ISIG,IV,N,KK,IISIG COMMON/QUANT2/KKK(NDMX),NVT(NDMX),IPRITY(NDMX) COMMON/CHARA/PARA(2,160),PR,PROBS(2,20000),REF(20000) COMMON/ROTOR/NROTOR,NDIMTO COMMON/C2C/PERC2L,PER23L(NDMX) DIMENSION EGVCR(NDMX,NDMX),EGVL(NDMX) & ,SUM(NDMX,9) ,EGVCI(NDMX,NDMX) DIMENSION EGVCV3R(KDMX),KAFTER(NDMX) DIMENSION EGVCV3I(KDMX) complex(8) Y,YCONJ,Y2,YCONJ2,Y3,YCONJ3,PERC2L,PER23L 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) YCONJ=dcmplx(EGVCR(I,II),-EGVCI(I,II)) Y=dcmplx(EGVCR(I,II),EGVCI(I,II)) YY=dreal(Y*YCONJ) c SUM(II,IKT)=EGVC(I,II)*EGVC(I,II)+SUM(II,IKT) SUM(II,IKT)=YY +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 IF(NVT(II).EQ.3.AND.N.LT.8.OR.NVT(II).GE.4) THEN c attention ik modifications aug-sep 2001! (next card c will make the code search for the bigest coefficients c for all vt! XMAX=(0.,0.) KKK(II)=-N DO 7 JJ=(2*N+1)*NVT(II)+1,(2*N+1)*NVT(II)+(2*N+1) Y2=dcmplx(EGVCR(JJ,II),EGVCI(JJ,II)) YCONJ2=dcmplx(EGVCR(JJ,II),-EGVCI(JJ,II)) YY2=dreal(Y2*YCONJ2) c IF (EGVC(JJ,II)*EGVC(JJ,II).GT.XMAX) THEN IF (YY2.GT.XMAX) THEN c XMAX=EGVC(JJ,II)*EGVC(JJ,II) XMAX=YY2 KKK(II)=JJ-(N+1)-NVT(II)*(2*N+1) END IF 7 CONTINUE CC cc changes by ik, oct9 2001 elseif(nvt(ii).eq.2) then if(N.EQ.0) then KKK(II)=0 elseif(N.EQ.1) then if(II.EQ.7) KKK(II)=-1 if(II.EQ.8) KKK(II)=0 if(II.EQ.9) KKK(II)=1 elseif(N.GE.2) then if(II.EQ.11) KKK(II)=-2 if(II.EQ.12) KKK(II)=-1 if(II.EQ.13.AND.N.EQ.2) KKK(II)=0 if(II.EQ.14.AND.N.EQ.2) KKK(II)=1 if(II.EQ.15.AND.N.EQ.2) KKK(II)=2 endif if(N.GE.3) then if(II.EQ.15) KKK(II)=-3 if(II.EQ.16) KKK(II)=-2 if(II.EQ.17.AND.N.EQ.3) KKK(II)=-1 if(II.EQ.18.AND.N.EQ.3) KKK(II)=0 if(II.EQ.19.AND.N.EQ.3) KKK(II)=1 if(N.EQ.3) then endif endif if(N.GE.4) then if(II.EQ.19) KKK(II)=-4 if(II.EQ.20) KKK(II)=-3 if(II.EQ.21.AND.N.EQ.4) KKK(II)=-2 if(II.EQ.22.AND.N.EQ.4) KKK(II)=-1 if(II.EQ.23.AND.N.EQ.4) KKK(II)=0 if(II.EQ.24.AND.N.EQ.4) KKK(II)=1 if(II.EQ.25.AND.N.EQ.4) KKK(II)=2 if(II.EQ.26.AND.N.EQ.4) KKK(II)=3 if(II.EQ.27.AND.N.EQ.4) KKK(II)=4 endif if(N.GE.5) then if(II.EQ.23) KKK(II)=-5 if(II.EQ.24) KKK(II)=-4 if(II.EQ.25.AND.N.EQ.5) KKK(II)=-3 if(II.EQ.26.AND.N.EQ.5) KKK(II)=-2 if(II.EQ.27.AND.N.EQ.5) KKK(II)=-1 if(II.EQ.28.AND.N.EQ.5) KKK(II)=0 if(II.EQ.29.AND.N.EQ.5) KKK(II)=1 if(II.EQ.30.AND.N.EQ.5) KKK(II)=2 if(II.EQ.31.AND.N.EQ.5) KKK(II)=3 if(II.EQ.32.AND.N.EQ.5) KKK(II)=4 if(II.EQ.33.AND.N.EQ.5) KKK(II)=5 endif if(N.GE.6) then if(II.EQ.27) KKK(II)=-6 if(II.EQ.28) KKK(II)=-5 if(II.EQ.29.AND.N.EQ.6) KKK(II)=-4 if(II.EQ.30.AND.N.EQ.6) KKK(II)=-3 if(II.EQ.31.AND.N.EQ.6) KKK(II)=-2 if(II.EQ.32.AND.N.EQ.6) KKK(II)=-1 if(II.EQ.33.AND.N.EQ.6) KKK(II)=0 if(II.EQ.34.AND.N.EQ.6) KKK(II)=1 if(II.EQ.35.AND.N.EQ.6) KKK(II)=2 if(II.EQ.36.AND.N.EQ.6) KKK(II)=3 if(II.EQ.37.AND.N.EQ.6) KKK(II)=4 if(II.EQ.38.AND.N.EQ.6) KKK(II)=5 if(II.EQ.39.AND.N.EQ.6) KKK(II)=6 endif if(N.GE.7) then if(II.EQ.31) KKK(II)=-7 if(II.EQ.32) KKK(II)=-6 if(II.EQ.33.AND.N.EQ.7) KKK(II)=-5 if(II.EQ.34.AND.N.EQ.7) KKK(II)=-4 if(II.EQ.35.AND.N.EQ.7) KKK(II)=-3 if(II.EQ.36.AND.N.EQ.7) KKK(II)=-2 if(II.EQ.37.AND.N.EQ.7) KKK(II)=-1 if(II.EQ.38.AND.N.EQ.7) KKK(II)=0 if(II.EQ.39.AND.N.EQ.7) KKK(II)=1 if(II.EQ.40.AND.N.EQ.7) KKK(II)=2 if(II.EQ.41.AND.N.EQ.7) KKK(II)=3 if(II.EQ.42.AND.N.EQ.7) KKK(II)=4 if(II.EQ.43.AND.N.EQ.7) KKK(II)=5 if(II.EQ.44.AND.N.EQ.7) KKK(II)=6 if(II.EQ.45.AND.N.EQ.7) KKK(II)=7 endif if(N.GE.8) then if(II.EQ.35) KKK(II)=-8 if(II.EQ.36) KKK(II)=-7 if(II.EQ.37.AND.N.EQ.8) KKK(II)=-6 if(II.EQ.38.AND.N.EQ.8) KKK(II)=-5 if(II.EQ.39.AND.N.EQ.8) KKK(II)=-4 if(II.EQ.40.AND.N.EQ.8) KKK(II)=-3 if(II.EQ.41.AND.N.EQ.8) KKK(II)=-2 if(II.EQ.42.AND.N.EQ.8) KKK(II)=-1 if(II.EQ.43.AND.N.EQ.8) KKK(II)=0 if(II.EQ.44.AND.N.EQ.8) KKK(II)=1 if(II.EQ.45.AND.N.EQ.8) KKK(II)=2 if(II.EQ.46.AND.N.EQ.8) KKK(II)=3 if(II.EQ.47.AND.N.EQ.8) KKK(II)=4 if(II.EQ.48.AND.N.EQ.8) KKK(II)=5 if(II.EQ.49.AND.N.EQ.8) KKK(II)=6 if(II.EQ.50.AND.N.EQ.8) KKK(II)=7 if(II.EQ.51.AND.N.EQ.8) KKK(II)=8 endif if(N.GE.9) then if(II.EQ.39) KKK(II)=-9 if(II.EQ.40) KKK(II)=-8 if(II.EQ.41.AND.N.EQ.9) KKK(II)=-7 if(II.EQ.42.AND.N.EQ.9) KKK(II)=-6 if(II.EQ.43.AND.N.EQ.9) KKK(II)=-5 if(II.EQ.44.AND.N.EQ.9) KKK(II)=-4 if(II.EQ.45.AND.N.EQ.9) KKK(II)=-3 if(II.EQ.46.AND.N.EQ.9) KKK(II)=-2 if(II.EQ.47.AND.N.EQ.9) KKK(II)=-1 if(II.EQ.48.AND.N.EQ.9) KKK(II)=0 if(II.EQ.49.AND.N.EQ.9) KKK(II)=1 if(II.EQ.50.AND.N.EQ.9) KKK(II)=2 if(II.EQ.51.AND.N.EQ.9) KKK(II)=3 if(II.EQ.52.AND.N.EQ.9) KKK(II)=4 if(II.EQ.53.AND.N.EQ.9) KKK(II)=5 if(II.EQ.54.AND.N.EQ.9) KKK(II)=6 if(II.EQ.55.AND.N.EQ.9) KKK(II)=7 if(II.EQ.56.AND.N.EQ.9) KKK(II)=8 if(II.EQ.57.AND.N.EQ.9) KKK(II)=9 endif if(N.GE.10) then if(II.EQ.43) KKK(II)=-10 if(II.EQ.44) KKK(II)=-9 if(II.EQ.45.AND.N.EQ.10) KKK(II)=-8 if(II.EQ.46.AND.N.EQ.10) KKK(II)=-7 if(II.EQ.47.AND.N.EQ.10) KKK(II)=-6 if(II.EQ.48.AND.N.EQ.10) KKK(II)=-5 if(II.EQ.49.AND.N.EQ.10) KKK(II)=-4 if(II.EQ.50.AND.N.EQ.10) KKK(II)=-3 if(II.EQ.51.AND.N.EQ.10) KKK(II)=-2 if(II.EQ.52.AND.N.EQ.10) KKK(II)=-1 if(II.EQ.53.AND.N.EQ.10) KKK(II)=0 if(II.EQ.54.AND.N.EQ.10) KKK(II)=1 if(II.EQ.55.AND.N.EQ.10) KKK(II)=2 if(II.EQ.56.AND.N.EQ.10) KKK(II)=3 if(II.EQ.57.AND.N.EQ.10) KKK(II)=4 if(II.EQ.58.AND.N.EQ.10) KKK(II)=5 if(II.EQ.59.AND.N.EQ.10) KKK(II)=6 if(II.EQ.60.AND.N.EQ.10) KKK(II)=7 if(II.EQ.61.AND.N.EQ.10) KKK(II)=8 if(II.EQ.62.AND.N.EQ.10) KKK(II)=9 if(II.EQ.63.AND.N.EQ.10) KKK(II)=10 endif if(N.EQ.11) then if(II.EQ.47) KKK(II)=-11 if(II.EQ.48) KKK(II)=-10 if(II.EQ.49) KKK(II)=-9 if(II.EQ.50.AND.N.EQ.11) KKK(II)=-8 if(II.EQ.51.AND.N.EQ.11) KKK(II)=-7 if(II.EQ.52.AND.N.EQ.11) KKK(II)=-6 if(II.EQ.53.AND.N.EQ.11) KKK(II)=-5 if(II.EQ.54.AND.N.EQ.11) KKK(II)=-4 if(II.EQ.55.AND.N.EQ.11) KKK(II)=-3 if(II.EQ.56.AND.N.EQ.11) KKK(II)=-2 if(II.EQ.57.AND.N.EQ.11) KKK(II)=-1 if(II.EQ.58.AND.N.EQ.11) KKK(II)=0 if(II.EQ.59.AND.N.EQ.11) KKK(II)=1 if(II.EQ.60.AND.N.EQ.11) KKK(II)=2 if(II.EQ.61.AND.N.EQ.11) KKK(II)=3 if(II.EQ.62.AND.N.EQ.11) KKK(II)=4 if(II.EQ.63.AND.N.EQ.11) KKK(II)=5 if(II.EQ.64.AND.N.EQ.11) KKK(II)=6 if(II.EQ.65.AND.N.EQ.11) KKK(II)=7 if(II.EQ.66.AND.N.EQ.11) KKK(II)=8 if(II.EQ.67.AND.N.EQ.11) KKK(II)=9 if(II.EQ.68.AND.N.EQ.11) KKK(II)=10 if(II.EQ.69.AND.N.EQ.11) KKK(II)=11 endif if(N.EQ.12) then if(II.EQ.51) KKK(II)=-12 if(II.EQ.52) KKK(II)=-11 if(II.EQ.53) KKK(II)=-10 if(II.EQ.54) KKK(II)=-9 if(II.EQ.55.AND.N.EQ.12) KKK(II)=-8 if(II.EQ.56.AND.N.EQ.12) KKK(II)=-7 if(II.EQ.57.AND.N.EQ.12) KKK(II)=-6 if(II.EQ.58.AND.N.EQ.12) KKK(II)=-5 if(II.EQ.59.AND.N.EQ.12) KKK(II)=-4 if(II.EQ.60.AND.N.EQ.12) KKK(II)=-3 if(II.EQ.61.AND.N.EQ.12) KKK(II)=-2 if(II.EQ.62.AND.N.EQ.12) KKK(II)=-1 if(II.EQ.63.AND.N.EQ.12) KKK(II)=0 if(II.EQ.64.AND.N.EQ.12) KKK(II)=1 if(II.EQ.65.AND.N.EQ.12) KKK(II)=2 if(II.EQ.66.AND.N.EQ.12) KKK(II)=3 if(II.EQ.67.AND.N.EQ.12) KKK(II)=4 if(II.EQ.68.AND.N.EQ.12) KKK(II)=5 if(II.EQ.69.AND.N.EQ.12) KKK(II)=6 if(II.EQ.70.AND.N.EQ.12) KKK(II)=7 if(II.EQ.71.AND.N.EQ.12) KKK(II)=8 if(II.EQ.72.AND.N.EQ.12) KKK(II)=9 if(II.EQ.73.AND.N.EQ.12) KKK(II)=10 if(II.EQ.74.AND.N.EQ.12) KKK(II)=11 if(II.EQ.75.AND.N.EQ.12) KKK(II)=12 endif if(N.EQ.13) then if(II.EQ.55) KKK(II)=-13 if(II.EQ.56) KKK(II)=-12 if(II.EQ.57) KKK(II)=-11 if(II.EQ.58) KKK(II)=-10 if(II.EQ.59) KKK(II)=-9 if(II.EQ.60.AND.N.EQ.13) KKK(II)=-8 if(II.EQ.61.AND.N.EQ.13) KKK(II)=-7 if(II.EQ.62.AND.N.EQ.13) KKK(II)=-6 if(II.EQ.63.AND.N.EQ.13) KKK(II)=-5 if(II.EQ.64.AND.N.EQ.13) KKK(II)=-4 if(II.EQ.65.AND.N.EQ.13) KKK(II)=-3 if(II.EQ.66.AND.N.EQ.13) KKK(II)=-2 if(II.EQ.67.AND.N.EQ.13) KKK(II)=-1 if(II.EQ.68.AND.N.EQ.13) KKK(II)=0 if(II.EQ.69.AND.N.EQ.13) KKK(II)=1 if(II.EQ.70.AND.N.EQ.13) KKK(II)=2 if(II.EQ.71.AND.N.EQ.13) KKK(II)=3 if(II.EQ.72.AND.N.EQ.13) KKK(II)=4 if(II.EQ.73.AND.N.EQ.13) KKK(II)=5 if(II.EQ.74.AND.N.EQ.13) KKK(II)=6 if(II.EQ.75.AND.N.EQ.13) KKK(II)=7 if(II.EQ.76.AND.N.EQ.13) KKK(II)=8 if(II.EQ.77.AND.N.EQ.13) KKK(II)=9 if(II.EQ.78.AND.N.EQ.13) KKK(II)=10 if(II.EQ.79.AND.N.EQ.13) KKK(II)=11 if(II.EQ.80.AND.N.EQ.13) KKK(II)=12 if(II.EQ.81.AND.N.EQ.13) KKK(II)=13 endif if(N.EQ.14) then if(II.EQ.59) KKK(II)=-14 if(II.EQ.60) KKK(II)=-13 if(II.EQ.61) KKK(II)=-12 if(II.EQ.62) KKK(II)=-11 if(II.EQ.63) KKK(II)=-10 if(II.EQ.64) KKK(II)=-9 if(II.EQ.65.AND.N.EQ.14) KKK(II)=-8 if(II.EQ.66.AND.N.EQ.14) KKK(II)=-7 if(II.EQ.67.AND.N.EQ.14) KKK(II)=-6 if(II.EQ.68.AND.N.EQ.14) KKK(II)=-5 if(II.EQ.69.AND.N.EQ.14) KKK(II)=-4 if(II.EQ.70.AND.N.EQ.14) KKK(II)=-3 if(II.EQ.71.AND.N.EQ.14) KKK(II)=-2 if(II.EQ.72.AND.N.EQ.14) KKK(II)=-1 if(II.EQ.73.AND.N.EQ.14) KKK(II)=0 if(II.EQ.74.AND.N.EQ.14) KKK(II)=1 if(II.EQ.75.AND.N.EQ.14) KKK(II)=2 if(II.EQ.76.AND.N.EQ.14) KKK(II)=3 if(II.EQ.77.AND.N.EQ.14) KKK(II)=4 if(II.EQ.78.AND.N.EQ.14) KKK(II)=5 if(II.EQ.79.AND.N.EQ.14) KKK(II)=6 if(II.EQ.80.AND.N.EQ.14) KKK(II)=7 if(II.EQ.81.AND.N.EQ.14) KKK(II)=8 if(II.EQ.82.AND.N.EQ.14) KKK(II)=9 if(II.EQ.83.AND.N.EQ.14) KKK(II)=10 if(II.EQ.84.AND.N.EQ.14) KKK(II)=11 c they are labeled vt=3 (85 and 86)! c if(II.EQ.85.AND.N.EQ.14) KKK(II)=12 c if(II.EQ.86.AND.N.EQ.14) KKK(II)=13 if(II.EQ.87.AND.N.EQ.14) KKK(II)=14 endif if(N.EQ.15) then if(II.EQ.63) KKK(II)=-15 if(II.EQ.64) KKK(II)=-14 if(II.EQ.65) KKK(II)=-13 if(II.EQ.66) KKK(II)=-12 if(II.EQ.67) KKK(II)=-11 if(II.EQ.68) KKK(II)=-10 if(II.EQ.69) KKK(II)=-9 if(II.EQ.70.AND.N.EQ.15) KKK(II)=-8 if(II.EQ.71.AND.N.EQ.15) KKK(II)=-7 if(II.EQ.72.AND.N.EQ.15) KKK(II)=-6 if(II.EQ.73.AND.N.EQ.15) KKK(II)=-5 if(II.EQ.74.AND.N.EQ.15) KKK(II)=-4 if(II.EQ.75.AND.N.EQ.15) KKK(II)=-3 if(II.EQ.76.AND.N.EQ.15) KKK(II)=-2 if(II.EQ.77.AND.N.EQ.15) KKK(II)=-1 if(II.EQ.78.AND.N.EQ.15) KKK(II)=0 if(II.EQ.79.AND.N.EQ.15) KKK(II)=1 if(II.EQ.80.AND.N.EQ.15) KKK(II)=2 if(II.EQ.81.AND.N.EQ.15) KKK(II)=3 if(II.EQ.82.AND.N.EQ.15) KKK(II)=4 if(II.EQ.83.AND.N.EQ.15) KKK(II)=5 if(II.EQ.84.AND.N.EQ.15) KKK(II)=6 if(II.EQ.85.AND.N.EQ.15) KKK(II)=7 if(II.EQ.86.AND.N.EQ.15) KKK(II)=8 if(II.EQ.87.AND.N.EQ.15) KKK(II)=9 if(II.EQ.88.AND.N.EQ.15) KKK(II)=10 if(II.EQ.89.AND.N.EQ.15) KKK(II)=11 if(II.EQ.90.AND.N.EQ.15) KKK(II)=12 if(II.EQ.91.AND.N.EQ.15) KKK(II)=13 if(II.EQ.92.AND.N.EQ.15) KKK(II)=14 if(II.EQ.93.AND.N.EQ.15) KKK(II)=15 if(II.GE.94.AND.N.EQ.15) NVT(II)=3 endif if(N.EQ.16) then if(II.EQ.67) KKK(II)=-16 if(II.EQ.68) KKK(II)=-15 if(II.EQ.69) KKK(II)=-14 if(II.EQ.70) KKK(II)=-13 if(II.EQ.71) KKK(II)=-12 if(II.EQ.72) KKK(II)=-11 if(II.EQ.73) KKK(II)=-10 if(II.EQ.74) KKK(II)=-9 if(II.EQ.75.AND.N.EQ.16) KKK(II)=-8 if(II.EQ.76.AND.N.EQ.16) KKK(II)=-7 if(II.EQ.77.AND.N.EQ.16) KKK(II)=-6 if(II.EQ.78.AND.N.EQ.16) KKK(II)=-5 if(II.EQ.79.AND.N.EQ.16) KKK(II)=-4 if(II.EQ.80.AND.N.EQ.16) KKK(II)=-3 if(II.EQ.81.AND.N.EQ.16) KKK(II)=-2 if(II.EQ.82.AND.N.EQ.16) KKK(II)=-1 if(II.EQ.83.AND.N.EQ.16) KKK(II)=0 if(II.EQ.84.AND.N.EQ.16) KKK(II)=1 if(II.EQ.85.AND.N.EQ.16) KKK(II)=2 if(II.EQ.86.AND.N.EQ.16) KKK(II)=3 if(II.EQ.87.AND.N.EQ.16) KKK(II)=4 if(II.EQ.88.AND.N.EQ.16) KKK(II)=5 if(II.EQ.89.AND.N.EQ.16) KKK(II)=6 if(II.EQ.90.AND.N.EQ.16) KKK(II)=7 if(II.EQ.91.AND.N.EQ.16) KKK(II)=8 if(II.EQ.92.AND.N.EQ.16) KKK(II)=9 if(II.EQ.93.AND.N.EQ.16) KKK(II)=10 if(II.EQ.94.AND.N.EQ.16) KKK(II)=11 if(II.EQ.95.AND.N.EQ.16) KKK(II)=12 if(II.EQ.96.AND.N.EQ.16) KKK(II)=13 if(II.EQ.97.AND.N.EQ.16) KKK(II)=14 if(II.EQ.98.AND.N.EQ.16) KKK(II)=15 if(II.EQ.99.AND.N.EQ.16) KKK(II)=16 if(II.GE.100.AND.N.EQ.16) NVT(II)=3 endif if(N.EQ.17) then if(II.EQ.71) KKK(II)=-17 if(II.EQ.72) KKK(II)=-16 if(II.EQ.73) KKK(II)=-15 if(II.EQ.74) KKK(II)=-14 if(II.EQ.75) KKK(II)=-13 if(II.EQ.76) KKK(II)=-12 if(II.EQ.77) KKK(II)=-11 if(II.EQ.78) KKK(II)=-10 if(II.EQ.79) KKK(II)=-9 if(II.EQ.80.AND.N.EQ.17) KKK(II)=-8 if(II.EQ.81.AND.N.EQ.17) KKK(II)=-7 if(II.EQ.82.AND.N.EQ.17) KKK(II)=-6 if(II.EQ.83.AND.N.EQ.17) KKK(II)=-5 if(II.EQ.84.AND.N.EQ.17) KKK(II)=-4 if(II.EQ.85.AND.N.EQ.17) KKK(II)=-3 if(II.EQ.86.AND.N.EQ.17) KKK(II)=-2 if(II.EQ.87.AND.N.EQ.17) KKK(II)=-1 if(II.EQ.88.AND.N.EQ.17) KKK(II)=0 if(II.EQ.89.AND.N.EQ.17) KKK(II)=1 if(II.EQ.90.AND.N.EQ.17) KKK(II)=2 if(II.EQ.91.AND.N.EQ.17) KKK(II)=3 if(II.EQ.92.AND.N.EQ.17) KKK(II)=4 if(II.EQ.93.AND.N.EQ.17) KKK(II)=5 if(II.EQ.94.AND.N.EQ.17) KKK(II)=6 if(II.EQ.95.AND.N.EQ.17) KKK(II)=7 if(II.EQ.96.AND.N.EQ.17) KKK(II)=8 if(II.EQ.97.AND.N.EQ.17) KKK(II)=9 if(II.EQ.98.AND.N.EQ.17) KKK(II)=10 if(II.EQ.99.AND.N.EQ.17) KKK(II)=11 if(II.EQ.100.AND.N.EQ.17) KKK(II)=12 if(II.EQ.101.AND.N.EQ.17) KKK(II)=13 if(II.EQ.102.AND.N.EQ.17) KKK(II)=14 if(II.EQ.103.AND.N.EQ.17) KKK(II)=15 if(II.EQ.104.AND.N.EQ.17) KKK(II)=16 if(II.EQ.105.AND.N.EQ.17) KKK(II)=17 if(II.GE.106.AND.N.EQ.17) NVT(II)=3 endif if(N.EQ.18) then if(II.EQ.77) KKK(II)=-18 if(II.EQ.78) KKK(II)=-17 if(II.EQ.79) KKK(II)=-16 if(II.EQ.80) KKK(II)=-15 if(II.EQ.81) KKK(II)=-14 if(II.EQ.82) KKK(II)=-13 if(II.EQ.83) KKK(II)=-12 if(II.EQ.84) KKK(II)=-11 if(II.EQ.85) KKK(II)=-10 if(II.EQ.86) KKK(II)=-9 if(II.EQ.87.AND.N.EQ.18) KKK(II)=-8 if(II.EQ.88.AND.N.EQ.18) KKK(II)=-7 if(II.EQ.89.AND.N.EQ.18) KKK(II)=-6 if(II.EQ.90.AND.N.EQ.18) KKK(II)=-5 if(II.EQ.91.AND.N.EQ.18) KKK(II)=-4 if(II.EQ.92.AND.N.EQ.18) KKK(II)=-3 if(II.EQ.93.AND.N.EQ.18) KKK(II)=-2 if(II.EQ.94.AND.N.EQ.18) KKK(II)=-1 if(II.EQ.95.AND.N.EQ.18) KKK(II)=0 if(II.EQ.96.AND.N.EQ.18) KKK(II)=1 if(II.EQ.97.AND.N.EQ.18) KKK(II)=2 if(II.EQ.98.AND.N.EQ.18) KKK(II)=3 if(II.EQ.99.AND.N.EQ.18) KKK(II)=4 if(II.EQ.100.AND.N.EQ.18) KKK(II)=5 if(II.EQ.101.AND.N.EQ.18) KKK(II)=6 if(II.EQ.102.AND.N.EQ.18) KKK(II)=7 if(II.EQ.103.AND.N.EQ.18) KKK(II)=8 if(II.EQ.104.AND.N.EQ.18) KKK(II)=9 if(II.EQ.105.AND.N.EQ.18) KKK(II)=10 if(II.EQ.106.AND.N.EQ.18) KKK(II)=11 if(II.EQ.107.AND.N.EQ.18) KKK(II)=12 if(II.EQ.108.AND.N.EQ.18) KKK(II)=13 if(II.EQ.109.AND.N.EQ.18) KKK(II)=14 if(II.EQ.110.AND.N.EQ.18) KKK(II)=15 if(II.EQ.111.AND.N.EQ.18) KKK(II)=16 if(II.EQ.112.AND.N.EQ.18) KKK(II)=17 if(II.EQ.113.AND.N.EQ.18) KKK(II)=18 if(II.EQ.114.AND.N.EQ.18) NVT(II)=3 if(II.EQ.117.AND.N.EQ.18) NVT(II)=3 if(II.EQ.73.AND.N.EQ.18) NVT(II)=1 if(II.EQ.72.AND.N.EQ.18) NVT(II)=1 endif if(N.EQ.19) then if(II.EQ.83) KKK(II)=-19 if(II.EQ.84) KKK(II)=-18 if(II.EQ.85) KKK(II)=-17 if(II.EQ.86) KKK(II)=-16 if(II.EQ.87) KKK(II)=-15 if(II.EQ.88) KKK(II)=-14 if(II.EQ.89) KKK(II)=-13 if(II.EQ.90) KKK(II)=-12 if(II.EQ.91) KKK(II)=-11 if(II.EQ.92) KKK(II)=-10 if(II.EQ.93) KKK(II)=-9 if(II.EQ.94.AND.N.EQ.19) KKK(II)=-8 if(II.EQ.95.AND.N.EQ.19) KKK(II)=-7 if(II.EQ.96.AND.N.EQ.19) KKK(II)=-6 if(II.EQ.97.AND.N.EQ.19) KKK(II)=-5 if(II.EQ.98.AND.N.EQ.19) KKK(II)=-4 if(II.EQ.99.AND.N.EQ.19) KKK(II)=-3 if(II.EQ.100.AND.N.EQ.19) KKK(II)=-2 if(II.EQ.101.AND.N.EQ.19) KKK(II)=-1 if(II.EQ.102.AND.N.EQ.19) KKK(II)=0 if(II.EQ.103.AND.N.EQ.19) KKK(II)=1 if(II.EQ.104.AND.N.EQ.19) KKK(II)=2 if(II.EQ.105.AND.N.EQ.19) KKK(II)=3 if(II.EQ.106.AND.N.EQ.19) KKK(II)=4 if(II.EQ.107.AND.N.EQ.19) KKK(II)=5 if(II.EQ.108.AND.N.EQ.19) KKK(II)=6 if(II.EQ.109.AND.N.EQ.19) KKK(II)=7 if(II.EQ.110.AND.N.EQ.19) KKK(II)=8 if(II.EQ.111.AND.N.EQ.19) KKK(II)=9 if(II.EQ.112.AND.N.EQ.19) KKK(II)=10 if(II.EQ.113.AND.N.EQ.19) KKK(II)=11 if(II.EQ.114.AND.N.EQ.19) KKK(II)=12 if(II.EQ.115.AND.N.EQ.19) KKK(II)=13 if(II.EQ.116.AND.N.EQ.19) KKK(II)=14 if(II.EQ.117.AND.N.EQ.19) KKK(II)=15 if(II.EQ.118.AND.N.EQ.19) KKK(II)=16 if(II.EQ.119.AND.N.EQ.19) KKK(II)=17 if(II.EQ.120.AND.N.EQ.19) KKK(II)=18 if(II.EQ.121.AND.N.EQ.19) KKK(II)=19 if(II.EQ.122.AND.N.EQ.19) NVT(II)=3 if(II.EQ.123.AND.N.EQ.19) NVT(II)=3 if(II.LE.79.AND.N.EQ.19) NVT(II)=1 endif if(N.EQ.20) then if(II.EQ.89) KKK(II)=-20 if(II.EQ.90) KKK(II)=-19 if(II.EQ.91) KKK(II)=-18 if(II.EQ.92) KKK(II)=-17 if(II.EQ.93) KKK(II)=-16 if(II.EQ.94) KKK(II)=-15 if(II.EQ.95) KKK(II)=-14 if(II.EQ.96) KKK(II)=-13 if(II.EQ.97) KKK(II)=-12 if(II.EQ.98) KKK(II)=-11 if(II.EQ.99) KKK(II)=-10 if(II.EQ.100) KKK(II)=-9 if(II.EQ.101.AND.N.EQ.20) KKK(II)=-8 if(II.EQ.102.AND.N.EQ.20) KKK(II)=-7 if(II.EQ.103.AND.N.EQ.20) KKK(II)=-6 if(II.EQ.104.AND.N.EQ.20) KKK(II)=-5 if(II.EQ.105.AND.N.EQ.20) KKK(II)=-4 if(II.EQ.106.AND.N.EQ.20) KKK(II)=-3 if(II.EQ.107.AND.N.EQ.20) KKK(II)=-2 if(II.EQ.108.AND.N.EQ.20) KKK(II)=-1 if(II.EQ.109.AND.N.EQ.20) KKK(II)=0 if(II.EQ.110.AND.N.EQ.20) KKK(II)=1 if(II.EQ.111.AND.N.EQ.20) KKK(II)=2 if(II.EQ.112.AND.N.EQ.20) KKK(II)=3 if(II.EQ.113.AND.N.EQ.20) KKK(II)=4 if(II.EQ.114.AND.N.EQ.20) KKK(II)=5 if(II.EQ.115.AND.N.EQ.20) KKK(II)=6 if(II.EQ.116.AND.N.EQ.20) KKK(II)=7 if(II.EQ.117.AND.N.EQ.20) KKK(II)=8 if(II.EQ.118.AND.N.EQ.20) KKK(II)=9 if(II.EQ.119.AND.N.EQ.20) KKK(II)=10 if(II.EQ.120.AND.N.EQ.20) KKK(II)=11 if(II.EQ.121.AND.N.EQ.20) KKK(II)=12 if(II.EQ.122.AND.N.EQ.20) KKK(II)=13 if(II.EQ.123.AND.N.EQ.20) KKK(II)=14 if(II.EQ.124.AND.N.EQ.20) KKK(II)=15 if(II.EQ.125.AND.N.EQ.20) KKK(II)=16 if(II.EQ.126.AND.N.EQ.20) KKK(II)=17 if(II.EQ.127.AND.N.EQ.20) KKK(II)=18 if(II.EQ.128.AND.N.EQ.20) KKK(II)=19 if(II.EQ.129.AND.N.EQ.20) KKK(II)=20 if(II.EQ.131.AND.N.EQ.20) NVT(II)=3 if(II.LE.85.AND.N.EQ.20) NVT(II)=1 endif 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) EGVCV3R(IK)=EGVCR(I,II) EGVCV3I(IK)=EGVCI(I,II) 64 CONTINUE CALL WIGNER(EGVCV3R,EGVCV3I,II,EGVL,KAFTER) KKK(II)=KAFTER(II) if(N.EQ.14.AND.II.EQ.85) THEN KKK(II)=12 NVT(II)=2 ELSEif(N.EQ.14.AND.II.EQ.86) THEN KKK(II)=13 NVT(II)=2 ELSEif(N.EQ.15.AND.II.EQ.88) THEN KKK(II)=10 NVT(II)=2 ELSEif(N.EQ.15.AND.II.EQ.89) THEN KKK(II)=11 NVT(II)=2 ELSEif(N.EQ.15.AND.II.EQ.93) THEN KKK(II)=15 NVT(II)=2 ELSEif(N.EQ.16.AND.II.EQ.92) THEN KKK(II)=9 NVT(II)=2 ELSEif(N.EQ.16.AND.II.EQ.93) THEN KKK(II)=10 NVT(II)=2 ELSEif(N.EQ.16.AND.II.EQ.99) THEN KKK(II)=16 NVT(II)=2 ELSEif(N.EQ.17.AND.II.EQ.97) THEN KKK(II)=9 NVT(II)=2 ELSEif(N.EQ.17.AND.II.EQ.98) THEN KKK(II)=10 NVT(II)=2 ELSEif(N.EQ.17.AND.II.EQ.103)THEN KKK(II)=15 NVT(II)=2 ELSEif(N.EQ.17.AND.II.EQ.104)THEN KKK(II)=16 NVT(II)=2 ELSEif(N.EQ.17.AND.II.EQ.105)THEN KKK(II)=17 NVT(II)=2 ELSEif(N.EQ.18.AND.II.EQ.107)THEN KKK(II)=12 NVT(II)=2 ELSEif(N.EQ.18.AND.II.EQ.108)THEN KKK(II)=13 NVT(II)=2 ELSEif(N.EQ.18.AND.II.EQ.100)THEN KKK(II)=5 NVT(II)=2 ELSEif(N.EQ.18.AND.II.EQ.99) THEN KKK(II)=4 NVT(II)=2 ELSEif(N.EQ.19.AND.II.EQ.111)THEN KKK(II)=9 NVT(II)=2 ELSEif(N.EQ.19.AND.II.EQ.117)THEN KKK(II)=15 NVT(II)=2 ELSEif(N.EQ.19.AND.II.EQ.119)THEN KKK(II)=17 NVT(II)=2 ELSEif(N.EQ.19.AND.II.EQ.101)THEN KKK(II)=-1 NVT(II)=2 ELSEif(N.EQ.19.AND.II.EQ.100)THEN KKK(II)=-2 NVT(II)=2 ELSEif(N.EQ.20.AND.II.EQ.120)THEN KKK(II)=11 NVT(II)=2 ELSEif(N.EQ.20.AND.II.EQ.121)THEN KKK(II)=12 NVT(II)=2 ELSEif(N.EQ.20.AND.II.EQ.129)THEN KKK(II)=20 NVT(II)=2 ELSEif(N.EQ.20.AND.II.EQ.113)THEN KKK(II)=4 NVT(II)=2 ELSEif(N.EQ.20.AND.II.EQ.112)THEN KKK(II)=3 NVT(II)=2 ELSEif(N.EQ.20.AND.II.EQ.111)THEN KKK(II)=2 NVT(II)=2 ENDIF 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 change of sign 16 KKK(II)=-KKK(II) c16 IF (KK.EQ.KKK(II).AND.IV.EQ.NVT(II)) THEN 17 IF (KK.EQ.KKK(II).AND.IV.EQ.NVT(II)) THEN IPOSE=II C IF(N.EQ.10) 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(EGVCR,EGVCI,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 1,NN=(30)+1,ISIGMA=(2)) COMMON/QUANT/ISIG,IV,N,KK,IISIG COMMON/QUANT2/KKK(NDMX),NVT(NDMX),IPRITY(NDMX) COMMON/EIGEN/HR(NDMX,NDMX),HI(NDMX,NDMX),WORK(NDMX), *EGVC3R(KDMX,9),EGVC3I(KDMX,9),NBR(2),VECTPR(10,961,KDMX,9) *,VECTPI(10,961,KDMX,9) DIMENSION EGVCR(NDMX,NDMX),EGVL(NDMX) DIMENSION EGVCI(NDMX,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.13.OR.N.EQ.14) 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 EISCH1(NM,N,AR1,AI1,WR,ZR,ZI,IERR,WORK) c my insertion USE MSFLIB USE MSIMSL real*8 AR1(NM,NM),AI1(NM,NM),WR(NM),ZR(NM,NM),ZI(NM,NM),WORK(NM) integer nm,n,ierr complex(8), ALLOCATABLE :: ACMP(:,:), evcmp(:,:) real*8, ALLOCATABLE :: evecmp(:) allocate (acmp(n,n),evcmp(n,n),evecmp(n)) acmp=(0.d0,0.d0) ACMP=DCMPLX(AR1,AI1) do i=1,n do k=1,n acmp(i,k)=dcmplx(ar1(i,k),ai1(i,k)) enddo enddo call devchf(N,acmp,N,evecmp,evcmp,N) do i=1,n wr(i)=evecmp(n-i+1) do k=1,n zr(i,k)=dreal(evcmp(i,n-k+1)) zi(i,k)=dimag(evcmp(i,n-k+1)) enddo enddo deallocate (acmp,evcmp,evecmp) RETURN END C 13 novembre 1992INXC C *********************************************************************** C C FUNCTION TO CALCULATE 3-J SYMBOLS C FORMULA (5.1) OF R.D.COWAN, "THE THEORY OF ATOMIC STRUCTURE AND SPECTRA" C WRITTEN BY M.GODEFROID, NOVEMBER 1984. C C *********************************************************************** FUNCTION AD3J(J1,J2,J3,M1,M2) IMPLICIT REAL*8 ( A-H,O-Z ) COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS COMMON/FACTS/GAM(1000) DIMENSION MC(12) AD3J = 0. IF(IABS(J1-J2).GT.J3.OR.(J1+J2).LT.J3.OR.IABS(J2-J3).GT.J1.OR.(J2+ 1J3).LT.J1.OR.IABS(J3-J1).GT.J2.OR.(J3+J1).LT.J2) GO TO 99 IF(IABS(M1).GT.J1.OR.IABS(M2).GT.J2.OR.IABS(M1+M2).GT.J3) GO TO 99 IF ((IABS(M1)+IABS(M2)).EQ.0.AND.MOD(J1+J2+J3,4).NE.0) GO TO 99 MC(1) = J1 + J2 - J3 MC(2) = J1 - J2 + J3 MC(3) = -J1 + J2 + J3 MC(4) = J1 + M1 MC(5) = J1 - M1 MC(6) = J2 + M2 MC(7) = J2 - M2 MC(8) = J3 - M1 - M2 MC(9) = J3 + M1 + M2 MC(10) = J1 + J2 + J3 + 2 MC(11) = -J3 + J2 - M1 MC(12) = -J3 + J1 + M2 DO 6 I =1,12 IF (MOD (MC(I),2).NE.0) GO TO 98 MC(I) = MC(I)/2 6 CONTINUE IZD = MAX0(MC(11),MC(12),0) IZM = MIN0(MC(1),MC(5),MC(6)) ISIG = 1 IF (MOD(IZD,2).NE.0) ISIG = -ISIG FCT = GAM(MC(1)+1) + GAM(MC(2)+1) + GAM(MC(3)+1) 1 + GAM(MC(5)+1) + GAM(MC(4)+1) + GAM(MC(7)+1) 2 + GAM(MC(6)+1) + GAM(MC(8)+1) + GAM(MC(9)+1) 3 - GAM(MC(10)+1) FCT = FCT/2. AD3J = 0.0E0 DO 60 IZ = IZD,IZM ADEN = GAM(IZ+1) + GAM(MC(1)-IZ+1) + GAM(MC(5)-IZ+1) 1 + GAM(MC(6)-IZ+1) + GAM(-MC(11)+IZ+1) 2 + GAM(-MC(12)+IZ+1) ADEN = FLOAT(ISIG)/EXP(ADEN - FCT) AD3J = AD3J + ADEN ISIG = -ISIG 60 CONTINUE IF (MOD(J1-J2+M1+M2,4) .NE. 0) AD3J = -AD3J GO TO 99 98 WRITE(6,101) J1,J2,J3,M1,M2 101 FORMAT(60H ERROR IN ATTEMPTING TO CALCULATE 3-J SYMBOL WITH J - VA 1LUES,3I3,9H M-VALUES,2I3) 99 RETURN END C ********************************************************************* C C C CALCULATE THE LOGS OF FACTORIALS REQUIRED BY THE RACAH C COEFFICIENT ROUTINE RAC ( N.S. SCOTT) C C **************************************************************** SUBROUTINE FACTT IMPLICIT REAL*8 ( A-H,O-Z ) COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS COMMON/FACTS/GAM(1000) DATA FIFTY/50.0E0/ GAM(1) = ONE GAM(2) = ONE X = TWO print*,'X=',X,'GAM=',GAM(1),'GAM(2)=',GAM(2) DO 10 I = 3,50 GAM(I) = GAM(I-1)*X X = X + ONE 10 CONTINUE DO 20 I = 1,50 GAM(I) = DLOG(GAM(I)) 20 CONTINUE X = FIFTY DO 30 I = 51,500 GAM(I) = GAM(I-1) + DLOG(X) X = X + ONE 30 CONTINUE RETURN END SUBROUTINE INTEN(RINT,CST,K,IVV,INK,MUABC,ICTT,CF) IMPLICIT REAL*8 ( A-H,O-Z ) C THIS SUBROUTINE CALCULATES THE LINE STRENGTH OF THE CURRENT C LINE C**************************************************************** CHARACTER MUABC*6 CHARACTER*1 PR,PROBS CHARACTER*6 PARA,REF PARAMETER(NDMX=(2*(30)+1)*9,KDMX=2*(30)+1,NTORMX=2*(10)+1, 1NN=(30)+1,ISIGMA=(2)) COMMON/EIGEN/HR(NDMX,NDMX),HI(NDMX,NDMX),WORK(NDMX), *EGVC3R(KDMX,9),EGVC3I(KDMX,9),NBR(2),VECTPR(10,961,KDMX,9) *,VECTPI(10,961,KDMX,9) COMMON/TOR/A(9,NTORMX,2*KDMX,NN,ISIGMA),ETOR(2*KDMX,9) COMMON/ROTOR/NROTOR,NDIMTO COMMON/DAT/CONV,IBUG1,IBUG2,IBUG3,IBUG4,KTRONC,KTRON1 , * IBGTME,IBGVTD ,EVIB(2),IRMW,TERM COMMON/EXPDAT / ETRANS(20000),IVOBS(2,20000), * NOBS(2,20000),KOBS(2,20000),IBLK(2,20000),IW(20000),W(20000), * NDATA,NADAT,EPSI,NOFIT,NFITMW,NFITIR,NFIMW0 ,NFIMW1 ,NITT, * IAST(20000),NFI004 ,NFI080 ,NFI100 ,NFI020 ,NFI200 ,NFI045 , & NGST0 ,NFI010 ,SW070,NFI070 ,NFIMW2,IKAKC,JMAX,NFI1M0, & NFIR10,NFIR21,NFIR32,NFIMW3,NFIMW4,SWA,SWE,NFITMWA,NFITMWE &,INT C COMMON/C2C/PERC2L,PERC2S,PER23L,PER23S COMMON/QUANT/ISIG,IV,N,KK,IISIG COMMON/CHARA/PARA(2,160),PR,PROBS(2,20000),REF(20000) COMMON/INT/TPR,BLTZ,CONV2,SSQ,BLTZ2 DIMENSION CST(2,139),IVV(2),INK(2),ICTT(6),CTT(6),RCTT(6) complex(8) CPROD0,CPROD1,CPRODM1,CT,CTT,S,S2,S3,S4 complex(8) YCONJ,Y,PER23L,PERC2L,PER23S,PERC2S,A complex(8) COEFA,COEFA0,COEFA0B,COEFA0C,COEFAL,COEFAAL,COEFAS complex(8) COEFAAS,A2LO,A3LO,A2UP,A3UP complex(8) ANM11A,ANM11B,ANM11C,ANM1MA,ANM1MB,ANM1MC complex(8) ANM10A,ANM10B,ANM10C complex(8) AN00A,AN00B,AN00C,AN01A,AN01B,AN01C complex(8) AN0M1A,AN0M1B,AN0M1C,AN10A,AN10B,AN10C,AN11A,AN11B complex(8) AN11C,AN1M1A,AN1M1B,AN1M1C complex(8) TMUA,TMUA3,TMUB,TMUB3,TMUC3 C C Set-up of MUABS = 'ABCabc' C A for mu_a / B for mu_b / C for mu_c (zero in the present case) C a for mu_a(3) / b for mu_b(3) / c for mu_c(3) C CF=2.d0 rint=-1.d0 MUABC=' ' AMUA0=CST(1,135) AMUA3=CST(1,136) AMUB0=CST(1,137) AMUB3=CST(1,138) AMUC3=CST(1,139) NLOW=NOBS(1,K) NUP=NOBS(2,K) NLOW1 = NLOW+1 NUP1 = NUP+1 C P OR PRIME STANDS FOR LEFT OR LOWER KNP2=2*NLOW KN2=2*NUP Q=(KNP2+1.)*(KN2+1.) KLOW=KOBS(1,K) KUP=KOBS(2,K) IVVLO=IVV(1) IVVUP=IVV(2) INKLO=INK(1) INKUP=INK(2) S=(0.d0,0.d0) S2=(0.d0,0.d0) S4=(0.d0,0.d0) DO 1 M = 1,(6) CTT(M) =(0.d0,0.d0) ICTT(M) = 0 1 CONTINUE PERC2L=(0.d0,0.d0) PERC2S=(0.d0,0.d0) PER23L=(0.d0,0.d0) PER23S=(0.d0,0.d0) EPS=1.E-10 C INITIALIZATION OF THE SUM ON TORSIONAL EIGENFUNCTIONS AN00A=(0.d0,0.d0) AN00B=(0.d0,0.d0) AN00C=(0.d0,0.d0) AN01A=(0.d0,0.d0) AN01B=(0.d0,0.d0) AN01C=(0.d0,0.d0) AN0M1A=(0.d0,0.d0) AN0M1B=(0.d0,0.d0) AN0M1C=(0.d0,0.d0) AN10A=(0.d0,0.d0) AN10B=(0.d0,0.d0) AN10C=(0.d0,0.d0) AN11A=(0.d0,0.d0) AN11B=(0.d0,0.d0) AN11C=(0.d0,0.d0) AN1M1A=(0.d0,0.d0) AN1M1B=(0.d0,0.d0) AN1M1C=(0.d0,0.d0) ANM10A=(0.d0,0.d0) ANM10B=(0.d0,0.d0) ANM10C=(0.d0,0.d0) ANM11A=(0.d0,0.d0) ANM11B=(0.d0,0.d0) ANM11C=(0.d0,0.d0) ANM1MA=(0.d0,0.d0) ANM1MB=(0.d0,0.d0) ANM1MC=(0.d0,0.d0) GO TO 100 C C EXPECTATION VALUE OF C2(C) AND OF (23)* FOR LOWER 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.d0,0.d0) A3LO=(0.d0,0.d0) DO 298 III=1,NDIMTO IIIOPP=2*KTRONC+1-(III-1) COEFAL=dCONJG(A(IVTORP,III,ILOW,NLOW1,IISIG)) COEFAAL=A(IVTOR1,III,IOPPLO,NLOW1,IISIG) IF(ISIG.EQ.0) THEN COEF4L=A(IVTOR1,IIIOPP,IOPPLO,NLOW1,IISIG) ELSE COEF4L= (0.,0.) ENDIF A2LO=A2LO+COEFAL*COEFAAL A3LO=A3LO+COEFAL*COEF4L 298 CONTINUE YCONJ=dcmplx(VECTPR(IVVLO,INKLO,ILOW,IVTORP), 1-VECTPI(IVVLO,INKLO,ILOW,IVTORP)) Y=dcmplx(VECTPR(IVVLO,INKLO,IOPPLO,IVTOR1), 1VECTPI(IVVLO,INKLO,IOPPLO,IVTOR1)) PERC2L=PERC2L+A2LO*EXPPLO* 1YCONJ*Y cattention, here we have complex eigenvectors! how to do? c 1 VECTPR(IVVLO,INKLO,ILOW,IVTORP)* c 2 VECTPR(IVVLO,INKLO,IOPPLO,IVTOR1) PER23L=PER23L+A3LO*EXPPLO* 1 YCONJ*Y c 1 VECTPR(IVVLO,INKLO,ILOW,IVTORP)* c 2 VECTPR(IVVLO,INKLO,IOPPLO,IVTOR1) C PRINT*,'PER23L=',PER23L,'A3LO=',A3LO,'NLOW=',NLOW 300 CONTINUE 302 CONTINUE 304 CONTINUE C C EXPECTATION VALUE OF C2(C) AND OF (23)* FOR UPPER STATE C DO 404 IVTORP=1,9 DO 402 IVTOR1=1,9 DO 400 IUP=1,2*NUP+1 KBASUP=IUP-NUP-1 IOPPUP=-KBASUP+NUP+1 NPKUP=NUP+KBASUP EXPPUP=1. IF(MOD(NPKUP,2).NE.0) EXPPUP=-1. A2UP=(0.d0,0.d0) A3UP=(0.d0,0.d0) DO 398 III=1,NDIMTO IIIOPP=2*KTRONC+1-(III-1) COEFAS=dCONJG(A(IVTORP,III,IUP,NUP1,IISIG)) COEFAAS=A(IVTOR1,III,IOPPUP,NUP1,IISIG) IF(ISIG.EQ.0) THEN COEF4S=A(IVTOR1,IIIOPP,IOPPUP,NUP1,IISIG) ELSE COEF4S=(0.d0,0.d0) ENDIF A2UP=A2UP+COEFAS*COEFAAS A3UP=A3UP+COEFAS*COEF4S 398 CONTINUE YCONJ=dcmplx(VECTPR(IVVUP,INKUP,IUP,IVTORP), 1-VECTPI(IVVUP,INKUP,IUP,IVTORP)) Y=dcmplx(VECTPR(IVVUP,INKUP,IOPPUP,IVTOR1), 1VECTPI(IVVUP,INKUP,IOPPUP,IVTOR1)) PERC2S=PERC2S+A2UP*EXPPUP* 1 YCONJ*Y c 1 VECTPR(IVVUP,INKUP,IUP,IVTORP)* c 2 VECTPR(IVVUP,INKUP,IOPPUP,IVTOR1) PER23S=PER23S+A3UP*EXPPUP* 1 YCONJ*Y c 1 VECTPR(IVVUP,INKUP,IUP,IVTORP)* c 2 VECTPR(IVVUP,INKUP,IOPPUP,IVTOR1) C PRINT*,'PER23S=',PER23S,'A3UP=',A3UP,'NUP=',NUP 400 CONTINUE 402 CONTINUE 404 CONTINUE C C DELTA N=0 N'=N Nlow=Nup C 100 IF(NUP.EQ.NLOW) THEN C SUM ON VT,VT',K,K' C EQUIVALENT OF THE DO 1 I=1,NDM(1) AND DO 2 J=1,NDM(2) OF C SUBROUTINE LNSTR (GODEFROID) DO 1004 IVTORP=1,9 DO 1002 IVTOR1=1,9 DO 1000 ILOW=1,2*NLOW+1 DO 998 IUP=1,2*NUP+1 KBASLO=ILOW-NLOW-1 KBASUP=IUP-NUP-1 C KBASLO=VALUE OF K FOR THE BASIS FUNCTION ON THE LEFT C SIDE OF THE MATRIX ELEMENT; TAKEN AS THE LOWER (INITIAL) C STATE OF THE TRANSITION C KBASUP= SAME FOR THE RIGHT SIDE OF THE MATRIX ELEMENT C KK2,RIGHT K FROM THE BASIS WAVEFUNCTION C KKP2= LEFT KK2=2*KBASUP KKP2=2*KBASLO ISIGN=+1 IF(MOD(KNP2-KKP2,4).NE.0)ISIGN=-1 C C DELTA K=0 K'=K Klow=Kup C IF(IUP.EQ.ILOW) THEN C SUM ON THE TORSIONAL EIGENFUNCTIONS AN00A=(0.d0,0.d0) AN00B=(0.d0,0.d0) AN00C=(0.d0,0.d0) DO 996 III=1,NDIMTO COEFA=dconjg(A(IVTORP,III,ILOW,NLOW1,IISIG)) COEFA0=A(IVTOR1,III,ILOW,NUP1,IISIG) IF(III.EQ.1) THEN COEFA0B=(0.d0,0.d0) ELSE COEFA0B=A(IVTOR1,III-1,ILOW,NUP1,IISIG) ENDIF IF(III.EQ.NDIMTO) THEN COEFA0C=(0.d0,0.d0) ELSE COEFA0C=A(IVTOR1,III+1,ILOW,NUP1,IISIG) ENDIF AN00A=AN00A + COEFA*COEFA0 AN00B=AN00B + COEFA*COEFA0B AN00C=AN00C + COEFA*COEFA0C 996 CONTINUE YCONJ=dcmplx(VECTPR(IVVLO,INKLO,ILOW,IVTORP), 1-VECTPI(IVVLO,INKLO,ILOW,IVTORP)) Y=dcmplx(VECTPR(IVVUP,INKUP,ILOW,IVTOR1), 1VECTPI(IVVUP,INKUP,ILOW,IVTOR1)) CPROD0=YCONJ*Y c CPROD0=VECTPR(IVVLO,INKLO,ILOW,IVTORP)* c 1 VECTPR(IVVUP,INKUP,ILOW,IVTOR1) C IF(ABS(CPROD0).LT.EPS) GO TO 998 TMUA=AN00A*AMUA0 TMUA3=(AN00A-0.5d0*AN00B-0.5d0*AN00C)*AMUA3 CT=CPROD0*AD3J(KNP2,2,KN2,-KKP2,0)*ISIGN CTT(1) = CTT(1) + CT*TMUA CTT(4) = CTT(4) + CT*TMUA3 S=S+CT*(TMUA+TMUA3) C PRINT*,'S=',S,'CPROD0=',CPROD0,'AN00A=',AN00A, C 1 'AN00B=',AN00B,'AN00C=',AN00C,'CT=',CT,'TMUA=', C 2 TMUA,'AMUA0=',AMUA0 S4=S4+cdABS(CT*(TMUA+TMUA3)) C C DELTA K=+1 K=K'+1 Kup=Klow+1 C ELSEIF(IUP.EQ.(ILOW+1)) THEN C AN01A=(0.,0.) AN01B=(0.,0.) AN01C=(0.,0.) DO 1006 III=1,NDIMTO COEFA=dCONJG(A(IVTORP,III,ILOW,NLOW1,IISIG)) COEFA0=A(IVTOR1,III,ILOW+1,NUP1,IISIG) IF(III.EQ.1) THEN COEFA0B=(0.d0,0.d0) ELSE COEFA0B=A(IVTOR1,III-1,ILOW+1,NUP1,IISIG) ENDIF IF(III.EQ.NDIMTO) THEN COEFA0C=(0.d0,0.d0) ELSE COEFA0C=A(IVTOR1,III+1,ILOW+1,NUP1,IISIG) ENDIF AN01A=AN01A + COEFA*COEFA0 AN01B=AN01B + COEFA*COEFA0B AN01C=AN01C + COEFA*COEFA0C 1006 CONTINUE YCONJ=dcmplx(VECTPR(IVVLO,INKLO,ILOW,IVTORP), 1 -VECTPI(IVVLO,INKLO,ILOW,IVTORP)) Y=dcmplx(VECTPR(IVVUP,INKUP,ILOW+1,IVTOR1), 1 VECTPI(IVVUP,INKUP,ILOW+1,IVTOR1)) CPROD1=YCONJ*Y c CPROD1=VECTPR(IVVLO,INKLO,ILOW,IVTORP)* c 1 VECTPR(IVVUP,INKUP,ILOW+1,IVTOR1) IF(cdABS(CPROD1).LT.EPS) GO TO 998 TMUB=AN01A*AMUB0 TMUB3=(AN01A-0.5d0*(AN01B+AN01C))*AMUB3 TMUC3=0.5d0*(-AN01B+AN01C)*AMUC3 CT=CPROD1*AD3J(KNP2,2,KN2,-KKP2,-2)*ISIGN/dSQRT(2.d0) CTT(2) = CTT(2) + CT*TMUB CTT(5) = CTT(5) + CT*TMUB3 CTT(6) = CTT(6) + CT*TMUC3 S=S+CT*(TMUB+TMUB3+TMUC3) S4=S4+cdABS(CT*(TMUB+TMUB3+TMUC3)) C C DELTA K=-1 K=K'-1 Kup=Klow-1 C ELSEIF(IUP.EQ.(ILOW-1)) THEN AN0M1A=(0.d0,0.d0) AN0M1B=(0.d0,0.d0) AN0M1C=(0.d0,0.d0) DO 1016 III=1,NDIMTO COEFA=dCONJG(A(IVTORP,III,ILOW,NLOW1,IISIG)) COEFA0=A(IVTOR1,III,ILOW-1,NUP1,IISIG) IF(III.EQ.1) THEN COEFA0B=(0.,0.) ELSE COEFA0B=A(IVTOR1,III-1,ILOW-1,NUP1,IISIG) ENDIF IF(III.EQ.NDIMTO) THEN COEFA0C=(0.,0.) ELSE COEFA0C=A(IVTOR1,III+1,ILOW-1,NUP1,IISIG) ENDIF AN0M1A=AN0M1A + COEFA*COEFA0 AN0M1B=AN0M1B + COEFA*COEFA0B AN0M1C=AN0M1C + COEFA*COEFA0C 1016 CONTINUE YCONJ=dcmplx(VECTPR(IVVLO,INKLO,ILOW,IVTORP), 1-VECTPI(IVVLO,INKLO,ILOW,IVTORP)) Y=dcmplx(VECTPR(IVVUP,INKUP,ILOW-1,IVTOR1), 1VECTPI(IVVUP,INKUP,ILOW-1,IVTOR1)) CPRODM1=Y*YCONJ c CPRODM1=VECTPR(IVVLO,INKLO,ILOW,IVTORP)* c 1 VECTPR(IVVUP,INKUP,ILOW-1,IVTOR1) IF(cdABS(CPRODM1).LT.EPS) GO TO 998 TMUB=-AN0M1A*AMUB0 TMUB3=(-AN0M1A+0.5d0*(AN0M1B+AN0M1C))*AMUB3 TMUC3=0.5d0*(-AN0M1B+AN0M1C)*AMUC3 CT=CPRODM1*AD3J(KNP2,2,KN2,-KKP2,2)*ISIGN/dSQRT(2.d0) CTT(2) = CTT(2) + CT*TMUB CTT(5) = CTT(5) + CT*TMUB3 CTT(6) = CTT(6) + CT*TMUC3 S=S+CT*(TMUB+TMUB3+TMUC3) S4=S4+cdABS(CT*(TMUB+TMUB3+TMUC3)) ENDIF 998 CONTINUE 1000 CONTINUE 1002 CONTINUE 1004 CONTINUE C C DELTA N=+1 N=N'+1 Nup=Nlow+1 C ELSEIF(NUP.EQ.(NLOW+1)) THEN DO 1034 IVTORP=1,9 DO 1032 IVTOR1=1,9 DO 1030 ILOW=1,2*NLOW+1 DO 1028 IUP=1,2*NUP+1 C print*,' ivtorp = ',ivtorp,' ivtor1 = ',ivtor1 C print*,' ilow = ',ilow,' iup = ',iup KBASLO=ILOW-NLOW-1 KBASUP=IUP-NUP-1 KKP2=2*KBASLO KK2=2*KBASUP C print*,' kbaslo = ',kbaslo,' kbasup = ',kbasup ISIGN=+1 IF(MOD(KNP2-KKP2,4).NE.0)ISIGN=-1 C C DELTA K=0 K'=K Klow=Kup C IF(IUP.EQ.(ILOW+1)) THEN AN10A=(0.d0,0.d0) AN10B=(0.d0,0.d0) AN10C=(0.d0,0.d0) C print*,'AN10A avant calc=',AN10A DO 1026 III=1,NDIMTO COEFA=dCONJG(A(IVTORP,III,ILOW,NLOW1,IISIG)) COEFA0=A(IVTOR1,III,ILOW+1,NUP1,IISIG) c print*,'coefa=',coefa,'coefa0=',coefa0,'ivtor1=',ivtor1 c 1,'III=',III,'ilow=',ilow,'NUP1=',NUP1,'IISIG=',IISIG c 2,'NLOW1=',NLOW1,'A=',A(ivtor1,iii,ilow+1,NUP1,iisig) IF(III.EQ.1) THEN COEFA0B=(0.d0,0.d0) ELSE COEFA0B=A(IVTOR1,III-1,ILOW+1,NUP1,IISIG) ENDIF IF(III.EQ.NDIMTO) THEN COEFA0C=(0.d0,0.d0) ELSE COEFA0C=A(IVTOR1,III+1,ILOW+1,NUP1,IISIG) ENDIF AN10A=AN10A + COEFA*COEFA0 AN10B=AN10B + COEFA*COEFA0B AN10C=AN10C + COEFA*COEFA0C 1026 CONTINUE YCONJ=dcmplx(VECTPR(IVVLO,INKLO,ILOW,IVTORP), 1-VECTPI(IVVLO,INKLO,ILOW,IVTORP)) Y=dcmplx(VECTPR(IVVUP,INKUP,ILOW+1,IVTOR1), 1VECTPI(IVVUP,INKUP,ILOW+1,IVTOR1)) CPROD0=YCONJ*Y c CPROD0=VECTPR(IVVLO,INKLO,ILOW,IVTORP)* c 1 VECTPR(IVVUP,INKUP,ILOW+1,IVTOR1) c print*,' cprod0 = ',cprod0 IF(cdABS(CPROD0).LT.EPS) GO TO 1028 TMUA=AN10A*AMUA0 c print*,'AN10A=',AN10A,'TMUA=',TMUA,'AMUA0=',AMUA0 TMUA3=(AN10A-0.5d0*AN10B-0.5d0*AN10C)*AMUA3 CT=CPROD0*AD3J(KNP2,2,KN2,-KKP2,0)*ISIGN CTT(1) = CTT(1) + CT*TMUA CTT(4) = CTT(4) + CT*TMUA3 S=S+CT*(TMUA+TMUA3) S4=S4+cdABS(CT*(TMUA+TMUA3)) C PRINT*,'AD3J=',AD3J(KNP2,2,KN2,-KKP2,0),'KNP2=',KNP2, C 1 'KN2=',KN2,'KKP2=',KKP2 c print*,' in delta k = 0 : ct = ',ct,' s = ',s,'TMUA=',TMUA c 1,'cprod0=',cprod0 C C DELTA K=+1 K=K'+1 Kup=Klow+1 C ELSEIF(IUP.EQ.(ILOW+2)) THEN AN11A=(0.d0,0.d0) AN11B=(0.d0,0.d0) AN11C=(0.d0,0.d0) DO 1036 III=1,NDIMTO COEFA=dCONJG(A(IVTORP,III,ILOW,NLOW1,IISIG)) COEFA0=A(IVTOR1,III,ILOW+2,NUP1,IISIG) IF(III.EQ.1) THEN COEFA0B=(0.d0,0.d0) ELSE COEFA0B=A(IVTOR1,III-1,ILOW+2,NUP1,IISIG) ENDIF IF(III.EQ.NDIMTO) THEN COEFA0C=(0.,0.) ELSE COEFA0C=A(IVTOR1,III+1,ILOW+2,NUP1,IISIG) ENDIF AN11A=AN11A + COEFA*COEFA0 AN11B=AN11B + COEFA*COEFA0B AN11C=AN11C + COEFA*COEFA0C 1036 CONTINUE YCONJ=dcmplx(VECTPR(IVVLO,INKLO,ILOW,IVTORP), 1-VECTPI(IVVLO,INKLO,ILOW,IVTORP)) Y=dcmplx(VECTPR(IVVUP,INKUP,ILOW+2,IVTOR1), 1VECTPI(IVVUP,INKUP,ILOW+2,IVTOR1)) CPROD1=YCONJ*Y c CPROD1=VECTPR(IVVLO,INKLO,ILOW,IVTORP)* c 1 VECTPR(IVVUP,INKUP,ILOW+2,IVTOR1) c print*,' cprod1 = ',cprod1 IF(cdABS(CPROD1).LT.EPS) GO TO 1028 TMUB=AN11A*AMUB0 TMUB3=(AN11A-0.5d0*(AN11B+AN11C))*AMUB3 TMUC3=0.5d0*(-AN11B+AN11C)*AMUC3 CT=CPROD1*AD3J(KNP2,2,KN2,-KKP2,-2)*ISIGN/dSQRT(2.d0) CTT(2) = CTT(2) + CT*TMUB CTT(5) = CTT(5) + CT*TMUB3 CTT(6) = CTT(6) + CT*TMUC3 S=S+CT*(TMUB+TMUB3+TMUC3) S4=S4+cdABS(CT*(TMUB+TMUB3+TMUC3)) C PRINT*,'AD3J=',AD3J(KNP2,2,KN2,-KKP2,-2),'KNP2=',KNP2, C 1 'KN2=',KN2,'KKP2=',KKP2 c print*,' in delta k = +1 : ct = ',ct,' s = ',s,'TMUB=',TMUB c 1,'cprod1=',cprod1,'AN11A=',AN11A C C DELTA K=-1 K=K'-1 Kup=Klow-1 C ELSEIF(IUP.EQ.ILOW) THEN AN1M1A=(0.,0.) AN1M1B=(0.,0.) AN1M1C=(0.,0.) DO 1046 III=1,NDIMTO COEFA=dCONJG(A(IVTORP,III,ILOW,NLOW1,IISIG)) COEFA0=A(IVTOR1,III,ILOW,NUP1,IISIG) IF(III.EQ.1) THEN COEFA0B=(0.d0,0.d0) ELSE COEFA0B=A(IVTOR1,III-1,ILOW,NUP1,IISIG) ENDIF IF(III.EQ.NDIMTO) THEN COEFA0C=(0.d0,0.d0) ELSE COEFA0C=A(IVTOR1,III+1,ILOW,NUP1,IISIG) ENDIF AN1M1A=AN1M1A + COEFA*COEFA0 c print*,'AN1M1A=',AN1M1A,'COEFA=',COEFA,'coefa0=',coefa0 AN1M1B=AN1M1B + COEFA*COEFA0B AN1M1C=AN1M1C + COEFA*COEFA0C 1046 CONTINUE YCONJ=dcmplx(VECTPR(IVVLO,INKLO,ILOW,IVTORP), 1-VECTPI(IVVLO,INKLO,ILOW,IVTORP)) Y=dcmplx(VECTPR(IVVUP,INKUP,ILOW,IVTOR1), 1VECTPI(IVVUP,INKUP,ILOW,IVTOR1)) CPRODM1=YCONJ*Y c CPRODM1=VECTPR(IVVLO,INKLO,ILOW,IVTORP)* c 1 VECTPR(IVVUP,INKUP,ILOW,IVTOR1) c print*,' cprodm1 = ',cprodm1 IF(cdABS(CPRODM1).LT.EPS) GO TO 1028 TMUB=-AN1M1A*AMUB0 TMUB3=(-AN1M1A+0.5d0*(AN1M1B+AN1M1C))*AMUB3 TMUC3=0.5d0*(-AN1M1B+AN1M1C)*AMUC3 CT=CPRODM1*AD3J(KNP2,2,KN2,-KKP2,2)*ISIGN/dSQRT(2.d0) CTT(2) = CTT(2) + CT*TMUB CTT(5) = CTT(5) + CT*TMUB3 CTT(6) = CTT(6) + CT*TMUC3 S=S+CT*(TMUB+TMUB3+TMUC3) S4=S4+cdABS(CT*(TMUB+TMUB3+TMUC3)) c PRINT*,'AD3J=',AD3J(KNP2,2,KN2,-KKP2,2),'KNP2=',KNP2, c 1 'KN2=',KN2,'KKP2=',KKP2 c print*,' in delta k = -1 : ct = ',ct,' s = ',s,'TMUB=',TMUB c 1,'TMUB=',TMUB,'cprodm1=',cprodm1,'AN1M1A=',AN1M1A ENDIF 1028 CONTINUE 1030 CONTINUE 1032 CONTINUE 1034 CONTINUE C C DELTA N=-1 C ELSEIF(NUP.EQ.(NLOW-1)) THEN DO 1064 IVTORP=1,9 DO 1062 IVTOR1=1,9 DO 1060 ILOW=1,2*NLOW+1 DO 1058 IUP=1,2*NUP+1 KBASLO=ILOW-NLOW-1 KBASUP=IUP-NUP-1 KKP2=2*KBASLO KK2=2*KBASUP ISIGN=+1 IF(MOD(KNP2-KKP2,4).NE.0)ISIGN=-1 C C DELTA K=0 K'=K Klow=Kup C IF(IUP.EQ.(ILOW-1)) THEN ANM10A=(0.d0,0.d0) ANM10B=(0.d0,0.d0) ANM10C=(0.d0,0.d0) DO 1056 III=1,NDIMTO COEFA=dCONJG(A(IVTORP,III,ILOW,NLOW1,IISIG)) COEFA0=A(IVTOR1,III,ILOW-1,NUP1,IISIG) IF(III.EQ.1) THEN COEFA0B=(0.d0,0.d0) ELSE COEFA0B=A(IVTOR1,III-1,ILOW-1,NUP1,IISIG) ENDIF IF(III.EQ.NDIMTO)THEN COEFA0C=(0.d0,0.d0) ELSE COEFA0C=A(IVTOR1,III+1,ILOW-1,NUP1,IISIG) ENDIF ANM10A=ANM10A + COEFA*COEFA0 ANM10B=ANM10B + COEFA*COEFA0B ANM10C=ANM10C + COEFA*COEFA0C 1056 CONTINUE YCONJ=dcmplx(VECTPR(IVVLO,INKLO,ILOW,IVTORP), 1-VECTPI(IVVLO,INKLO,ILOW,IVTORP)) Y=dcmplx(VECTPR(IVVUP,INKUP,ILOW-1,IVTOR1), 1VECTPI(IVVUP,INKUP,ILOW-1,IVTOR1)) CPROD0=YCONJ*Y c CPROD0=VECTPR(IVVLO,INKLO,ILOW,IVTORP)* c 1 VECTPR(IVVUP,INKUP,ILOW-1,IVTOR1) IF(cdABS(CPROD0).LT.EPS) GO TO 1058 TMUA=ANM10A*AMUA0 TMUA3=(ANM10A-0.5d0*ANM10B-0.5d0*ANM10C)*AMUA3 CT=CPROD0*AD3J(KNP2,2,KN2,-KKP2,0)*ISIGN CTT(1) = CTT(1) + CT*TMUA CTT(4) = CTT(4) + CT*TMUA3 S=S+CT*(TMUA+TMUA3) S4=S4+cdABS(CT*(TMUA+TMUA3)) C C DELTA K=+1 K=K'+1 Kup=Klow+1 C ELSEIF(IUP.EQ.ILOW) THEN ANM11A=(0.d0,0.d0) ANM11B=(0.d0,0.d0) ANM11C=(0.d0,0.d0) DO 1066 III=1,NDIMTO COEFA=dCONJG(A(IVTORP,III,ILOW,NLOW1,IISIG)) COEFA0=A(IVTOR1,III,ILOW,NUP1,IISIG) IF(III.EQ.1)THEN COEFA0B=(0.d0,0.d0) ELSE COEFA0B=A(IVTOR1,III-1,ILOW,NUP1,IISIG) ENDIF IF(III.EQ.NDIMTO)THEN COEFA0C=(0.d0,0.d0) ELSE COEFA0C=A(IVTOR1,III+1,ILOW,NUP1,IISIG) ENDIF ANM11A=ANM11A + COEFA*COEFA0 ANM11B=ANM11B+ COEFA*COEFA0B ANM11C=ANM11C + COEFA*COEFA0C 1066 CONTINUE CPROD1=VECTPR(IVVLO,INKLO,ILOW,IVTORP)* 1 VECTPR(IVVUP,INKUP,ILOW,IVTOR1) IF(cdABS(CPROD1).LT.EPS) GO TO 1058 TMUB=ANM11A*AMUB0 TMUB3=(ANM11A-0.5*(ANM11B+ANM11C))*AMUB3 TMUC3=0.5d0*(-ANM11B+ANM11C)*AMUC3 CT=CPROD1*AD3J(KNP2,2,KN2,-KKP2,-2)*ISIGN/dSQRT(2.d0) CTT(2) = CTT(2) + CT*TMUB CTT(5) = CTT(5) + CT*TMUB3 CTT(6) = CTT(6) + CT*TMUC3 S=S+CT*(TMUB+TMUB3+TMUC3) S4=S4+cdABS(CT*(TMUB+TMUB3+TMUC3)) C C DELTA K=-1 K=K'-1 Kup=Klow-1 C ELSEIF(IUP.EQ.(ILOW-2)) THEN ANM1MA=(0.d0,0.d0) ANM1MB=(0.d0,0.d0) ANM1MC=(0.d0,0.d0) DO 1076 III=1,NDIMTO COEFA=dCONJG(A(IVTORP,III,ILOW,NLOW1,IISIG)) IF(ILOW.EQ.1.OR.ILOW.EQ.2) THEN COEFA0=0.d0 ELSE COEFA0=A(IVTOR1,III,ILOW-2,NUP1,IISIG) ENDIF IF(III.EQ.1)THEN COEFA0B=(0.d0,0.d0) ELSE COEFA0B=A(IVTOR1,III-1,ILOW-2,NUP1,IISIG) ENDIF IF(III.EQ.NDIMTO)THEN COEFA0C=(0.d0,0.d0) ELSE COEFA0C=A(IVTOR1,III+1,ILOW-2,NUP1,IISIG) ENDIF ANM1MA=ANM1MA + COEFA*COEFA0 ANM1MB=ANM1MB + COEFA*COEFA0B ANM1MC=ANM1MC + COEFA*COEFA0C 1076 CONTINUE CPRODM1=VECTPR(IVVLO,INKLO,ILOW,IVTORP)* 1 VECTPR(IVVUP,INKUP,ILOW-2,IVTOR1) IF(cdABS(CPRODM1).LT.EPS) GO TO 1058 TMUB=-ANM1MA*AMUB0 TMUB3=(-ANM1MA+0.5d0*(ANM1MB+ANM1MC))*AMUB3 TMUC3=0.5d0*(-ANM1MB+ANM1MC)*AMUC3 CT=CPRODM1*AD3J(KNP2,2,KN2,-KKP2,2)*ISIGN/dSQRT(2.d0) CTT(2) = CTT(2) + CT*TMUB CTT(5) = CTT(5) + CT*TMUB3 CTT(6) = CTT(6) + CT*TMUC3 S=S+CT*(TMUB+TMUB3+TMUC3) S4=S4+cdABS(CT*(TMUB+TMUB3+TMUC3)) ENDIF 1058 CONTINUE 1060 CONTINUE 1062 CONTINUE 1064 CONTINUE ENDIF C IF(ABS(CTT(1)).GT.EPS) MUABC(1:1)='A' IF(ABS(CTT(2)).GT.EPS) MUABC(2:2)='B' IF(ABS(CTT(4)).GT.EPS) MUABC(4:4)='a' IF(ABS(CTT(5)).GT.EPS) MUABC(5:5)='b' IF(ABS(CTT(6)).GT.EPS) MUABC(6:6)='c' C S2 =(0.d0,0.d0) S3 =(0.d0,0.d0) DO 2 KK= 1,(6) S2 = S2 + CTT(KK) S3 = S3 + cdABS(CTT(KK)) 2 CONTINUE scscsc=cdabs(s-s2) IF(cdABS(S-S2).GT.EPS) return C c S=S**2 SS=dCONJG(S)*S C C If the line strength is larger than eps, then... C IF(SS.LE.EPS) GO TO 3001 C C ...calculate the percentages of contributions A,B,C,a,b,c to S^{1/2} C and keep the signs C DO 3 KK= 1,(6) RCTT(KK)=dreal(CTT(KK)) SS3=dreal(S3) ICTT(KK) = NINT(RCTT(KK)*100.d0/SS3) 3 CONTINUE C C ...evaluate the cancellation factor (Cowan, formula 14.107) C SS2=dreal(S2) SS4=dreal(S4) CF=(SS2/SS4)**2 C C add the degeneracy and temperature dependence factors C 3001 CONTINUE SSQ =SS*Q C BLTZ2=1. RINT=BLTZ2*SS*Q c print*,'RINT=',RINT,'S=',S,'Q=',Q,'BLTZ2=',BLTZ2,'SSQ=',SSQ c 1,'SS=',SS RETURN END