C NRB v1.2 14/02/07 PROGRAM MCONFIG C GENERATES CONFIGURATION INPUT FOR STG2 IMPLICIT REAL*8 (A-H,O-Z) C PARAMETER (MZLR1= 8) PARAMETER (MZNR1= 20) PARAMETER (MZNC2= 5000) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) C LOGICAL BTWO C DIMENSION MNAL(MXORB,MZNC2),MXAL(MXORB,MZNC2),MXN(MXORB,MZNC2) A ,IBASSH(MXORB,MZNC2),NXCITE(MZNC2),IOCSH(MZNC2) B ,JBASSH(MXORB,MZNC2),NI(MXORB),NTOTI(MXORB),MN(MXORB) C ,NSPARE(MZNC2),LOCSH(MZNC2),LBASSH(MXORB,MZNC2) C BTWO=.FALSE. C IZERO=0 IREAD=5 IWRITE=6 IPUNCH=8 C C OPEN(IREAD,FILE='dstgc',FORM='FORMATTED',STATUS='OLD') OPEN(IWRITE,FILE='routc',FORM='FORMATTED',STATUS='UNKNOWN') OPEN(IPUNCH,FILE='CONFIG.DAT',FORM='FORMATTED',STATUS='UNKNOWN') C C NUMBER OF CONFIGURATION SETS TO BE READ, AND ORBITALS C 1 READ (IREAD,*,END=200) NOPTN,MAXORB WRITE (IWRITE,3080) NOPTN,MAXORB C IF(NOPTN.LE.0)STOP 'NORMAL END' C IF(NOPTN.GT.MZNC2)THEN WRITE(IWRITE,3010)NOPTN STOP 'INCREASE MZNC2' ENDIF IF(MAXORB.GT.MXORB)THEN WRITE(IWRITE,3020)MAXORB STOP 'INCREASE MXORB' ENDIF C C A CONFIGURATION SET CONSISTS OF MIN OCCUPATION NOS, MAX C OCCUPATION NOS, OCCUPATION NOS OF A BASIC CONFIGURATION C TOGETHER WITH NUMBER OF EXCITATIONS FROM THE BASIC CONFIG. C DO M = 1,NOPTN READ (IREAD,*) (MNAL(I,M),I=1,MAXORB) WRITE (IWRITE,3090) (MNAL(I,M),I=1,MAXORB) READ (IREAD,*) (MXAL(I,M),I=1,MAXORB) WRITE (IWRITE,3100) (MXAL(I,M),I=1,MAXORB) READ (IREAD,*) (IBASSH(I,M),I=1,MAXORB),NXCITE(M) WRITE (IWRITE,3110) M, (IBASSH(I,M),I=1,MAXORB) WRITE (IWRITE,3120) NXCITE(M) ENDDO C C DETERMINE NUMBER OF ELECTRONS C NELC=0 DO I=1,MAXORB NELC=NELC+IBASSH(I,1) ENDDO WRITE(IWRITE,3270)NELC C C CHECK OTHER CONFIGS FOR CONSISTENCY C IFAIL=0 DO M=2,NOPTN N=0 DO I=1,MAXORB N=N+IBASSH(I,M) ENDDO IF(N.NE.NELC)THEN IFAIL=1 WRITE(IWRITE,3280)M,N ENDIF ENDDO C IF(IFAIL.NE.0)STOP 'CONFIGURATION MIS-MATCH' C C PERFORM SOME CHECKS ON MNAL AND MXAL FOR CONSISTENCY C IFAIL=0 DO M=1,NOPTN NSPARE(M)=NELC DO I=1,MAXORB NSPARE(M)=NSPARE(M)-MNAL(I,M) ENDDO IF(NSPARE(M).LT.0)THEN WRITE(IWRITE,3290)M IFAIL=1 ENDIF ENDDO C IF(IFAIL.NE.0)STOP 'MNAL INCONSISTENCY' C DO M=1,NOPTN DO I=1,MAXORB NE=MNAL(I,M)+NSPARE(M) IF(NE.LT.MXAL(I,M))THEN MXAL(I,M)=NE WRITE(IWRITE,3300)I,M ENDIF MXN(I,M)=MXAL(I,M)+1 ENDDO ENDDO C C CHECK CONSISTENCY OF BASIC CONFIG WITH MNAL,MXAL AND C STORE LAST OCCUPIED SHELL FOR EACH BASIC CONFIGURATION C IFAIL=0 DO 90 M = 1,NOPTN DO I = 1,MAXORB J = MAXORB - I + 1 IF (IBASSH(J,M).GT.0) THEN IOCSH(M) = J DO L=1,J IF(IBASSH(L,M).GT.MXAL(L,M))THEN WRITE(IWRITE,3292)M IFAIL=1 ELSEIF(IBASSH(L,M).LT.MNAL(L,M))THEN WRITE(IWRITE,3295)M IFAIL=1 ENDIF ENDDO GOTO 90 ENDIF IF(MNAL(J,M).GT.0)THEN WRITE(IWRITE,3295)M IFAIL=1 ENDIF ENDDO 90 ENDDO C IF(IFAIL.NE.0)STOP'BASIC CONFIG INCONSISTENCY' C C LOOP OVER ALL POSSIBLE ELECTRON DISTRIBUTIONS C IFLG3=0 NCON=0 DO 140 M=1,NOPTN I = 0 110 CONTINUE I = I + 1 NI(I) = 0 120 CONTINUE NI(I) = NI(I) + 1 NSTOP = I MI = MXN(I,M) - NI(I) IF (MI.LT.MNAL(NSTOP,M)) GOTO 130 NTOT = MI IF (I.GT.1) NTOT = NTOT + NTOTI(I-1) NTOTI(I) = NTOT MN(I) = MI IF (NTOT.GT.NELC) GOTO 130 IF (NTOT.LT.NELC) GO TO 125 C C TEST FOR EXCITATION ALLOWED FROM THE BASIC CONFIGURATIONS C NEX = 0 DO 20 L = 1,IOCSH(M) IF (L.GT.NSTOP) THEN NEX = NEX + IBASSH(L,M) GOTO 20 ENDIF MB = IBASSH(L,M) MA = MN(L) IF (MA.LT.MB) NEX = NEX + MB - MA 20 ENDDO IF (NEX.LE.NXCITE(M)) THEN !ALLOWED DO N=1,NCON !SEE IF WE ALREADY HAVE IT DO L=1,NSTOP IF(MN(L).NE.JBASSH(L,N))GO TO 122 ENDDO GO TO 125 !OLD 122 ENDDO IF(BTWO)THEN !SEE IF N+1 CAN BE FORMED FROM N CONFIG DO L=NSTOP+1,MAXORB MN(L)=0 ENDDO DO N=1,NCON1 IDIFF=0 LMAX=MAX(NSTOP,LOCSH(N)) DO L=1,LMAX IDIFF=IDIFF+IABS(LBASSH(L,N)-MN(L)) ENDDO IF(IDIFF.EQ.1)GO TO 124 !O.K. IF(IDIFF.EQ.0)STOP'ERROR, IDIFF=0!!' ENDDO GO TO 125 ENDIF C NEW 124 NCON=NCON+1 IF(NCON.GT.MZNC2)STOP 'INCREASE MZNC2' DO L=1,NSTOP JBASSH(L,NCON)=MN(L) IF(MN(L).GT.9)IFLG3=1 ENDDO DO L=NSTOP+1,MAXORB JBASSH(L,NCON)=0 ENDDO ENDIF C 125 IF (I.LT.MAXORB) GOTO 110 IF (I.GT.MAXORB) GOTO 140 130 CONTINUE IF (NI(I).LT.MXN(I,M)) GOTO 120 I = I - 1 IF (I.GT.0) GOTO 130 140 ENDDO C C DETERMINE GLOBAL MAX AND MIN OCCUPATIONS C DO M=2,NOPTN DO L=1,MAXORB MNAL(L,1)=MIN(MNAL(L,1),MNAL(L,M)) MXAL(L,1)=MAX(MXAL(L,1),MXAL(L,M)) ENDDO ENDDO C C WRITE CONFIGS TO FILE C WRITE(IPUNCH,*)NCON IF(IFLG3.EQ.0)THEN WRITE(IPUNCH,3352)(MNAL(L,1),L=1,MAXORB) WRITE(IPUNCH,3352)(MXAL(L,1),L=1,MAXORB) DO N=1,NCON WRITE(IPUNCH,3352)(JBASSH(L,N),L=1,MAXORB),IZERO ENDDO ELSE WRITE(IPUNCH,3353)(MNAL(L,1),L=1,MAXORB) WRITE(IPUNCH,3353)(MXAL(L,1),L=1,MAXORB) DO N=1,NCON WRITE(IPUNCH,3353)(JBASSH(L,N),L=1,MAXORB),IZERO ENDDO ENDIF C IF(BTWO)STOP 'NORMAL END' C BTWO=.TRUE. DO N=1,NCON DO I = 1,MAXORB IF (JBASSH(I,N).GT.0)LOCSH(N)=I ENDDO DO L=1,MAXORB LBASSH(L,N)=JBASSH(L,N) ENDDO ENDDO NCON1=NCON C GO TO 1 200 STOP'NO SECOND FILE' C 3010 FORMAT (' INCREASE MZNC2 TO ',I5) 3020 FORMAT (' INCREASE MXORB TO ',I3) 3080 FORMAT (/6X,'OPTION CHOSEN, NOPTN =',I3,' FOR ORBITALS MAXORB =' A ,I3) 3090 FORMAT ( A ' THE MINIMUM NUMBER OF ELECTRONS ALLOWED IN THIS SHELL IS' B ,2X, (20I3)) 3100 FORMAT ( A ' THE MAXIMUM NUMBER OF ELECTRONS ALLOWED IN THIS SHELL IS' B ,2X, (20I3)) 3110 FORMAT (' BASIC CONFIGURATION',I4,35X, (20I3)) 3120 FORMAT (' THE MAXIMUM NUMBER OF ELECTRON EXCITATIONS REQUIRED=', A I3) 3270 FORMAT (' TOTAL NUMBER OF ELECTRONS =',I3) 3280 FORMAT (' ERROR, CONFIGURATION ',I3,' HAS ',I3,' ELECTRONS') 3290 FORMAT (' ERROR, TOO MANY ELECTRONS REQUIRED BY MNAL FOR' A ,' CONFIGURATION',I3) 3292 FORMAT (' ERROR, BASIC OCCUPATION NO GT MXAL FOR CONFIG ',I3) 3295 FORMAT (' ERROR, BASIC OCCUPATION NO LT MNAL FOR CONFIG ',I3) 3300 FORMAT (' WARNING, MXAL TOO LARGE FOR ORBITAL ',I3 A ,' IN CONFIGURATION ',I3) 3352 FORMAT(60I2) 3353 FORMAT(40I3) END