*DECK SCRSAP SUBROUTINE SCRSAP(IPMAC,IPMEM,IACCS,NMIL,NMIX,NGRP,IMPX,HEQUI, 1 HMASL,NCAL,NSURFD,ILUPS,MIXC,TERP,LPURE,B2) * *----------------------------------------------------------------------- * *Purpose: * Build the Macrolib by scanning the NCAL elementary calculations of * a Saphyb and weighting them with TERP factors. * *Copyright: * Copyright (C) 2012 Ecole Polytechnique de Montreal * *Author(s): * A. Hebert * *Parameters: input * IPMAC address of the output Macrolib LCM object. * IPMEM pointer to the memory-resident Saphyb. * IACCS =0 macrolib is created; =1 ... is updated. * NMIL number of material mixtures in the Saphyb. * NMIX maximum number of material mixtures in the Macrolib. * NGRP number of energy groups. * IMPX print parameter (equal to zero for no print). * HEQUI keyword of SPH-factor set to be recovered. * HMASL keyword of MASL data set to be recovered. * NCAL number of elementary calculations in the Saphyb. * NSURFD number of discontinuity factors. * ILUPS up-scattering removing flag (=1 to remove up-scattering from * output cross-sections). * MIXC mixture index in the Saphyb corresponding to each Microlib * mixture. Equal to zero if a Microlib mixture is not updated. * TERP interpolation factors. * LPURE =.true. if the interpolation is a pure linear interpolation * with TERP factors. * B2 buckling * *----------------------------------------------------------------------- * USE GANLIB IMPLICIT NONE *---- * SUBROUTINE ARGUMENTS *---- TYPE(C_PTR) IPMAC,IPMEM INTEGER IACCS,NMIL,NMIX,NGRP,IMPX,NCAL,NSURFD,ILUPS,MIXC(NMIX) REAL TERP(NCAL,NMIX),B2 CHARACTER HEQUI*4,HMASL*4 LOGICAL LPURE *---- * LOCAL VARIABLES *---- INTEGER, PARAMETER::IOUT=6 INTEGER, PARAMETER::MAX1D=40 INTEGER, PARAMETER::MAX2D=20 INTEGER, PARAMETER::MAXED=30 INTEGER, PARAMETER::MAXNFI=1 INTEGER, PARAMETER::MAXNL=5 INTEGER, PARAMETER::NSTATE=40 INTEGER, PARAMETER::MAXRES=MAX1D-8 REAL FLOTVA, WEIGHT, FKEFF, B2R INTEGER I, I1D, I2D, IBM, IBMOLD, ICAL, IDEL, IDF, IED, IGMAX, & IGMIN, IGR, IKEFF, IL, ILONG, IMC, IOF, IPOSDE, ITRANC, ITYLCM, & ITYPE, JGR, LENGTH, N1D, N2D, NDEL, NED, NEDTMP, NF, NFTMP, NL, & NLTMP, NTYPE, NALBP TYPE(C_PTR) JPMAC,KPMAC,IPTMP,JPTMP,KPTMP INTEGER ISTATE(NSTATE),DIMSAP(50) LOGICAL LMAKE1(MAX1D),LMAKE2(MAX2D),LWD CHARACTER TEXT8*8,TEXT12*12,CM*2,HMAK1(MAX1D)*12,HMAK2(MAX2D)*12, 1 HVECT(MAXED)*8 *---- * ALLOCATABLE ARRAYS *---- INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS,IJJB,NJJB,IPOSB REAL, ALLOCATABLE, DIMENSION(:) :: GAR4,GAR4B,WORK1,WORK2,XVOLM, 1 ENERG,VOSAP,WDLA,FMASL,FMASLB REAL, ALLOCATABLE, DIMENSION(:,:) :: SPH REAL, ALLOCATABLE, DIMENSION(:,:,:) :: GAR1,ADF2 REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: GAR2,GAR3 CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: HADF REAL, POINTER, DIMENSION(:) :: FLOT TYPE(C_PTR) FLOT_PTR *---- * DATA STATEMENTS *---- DATA HMAK1 / 'FLUX-INTG','NTOT0','OVERV','DIFF','FLUX-INTG-P1', 1 'NTOT1','H-FACTOR','TRANC',MAXRES*' '/ *---- * SCRATCH STORAGE ALLOCATION *---- ALLOCATE(IJJ(NMIX),NJJ(NMIX),IPOS(NMIX),IJJB(NMIL),NJJB(NMIL), 1 IPOSB(NMIL)) ALLOCATE(GAR1(NMIX,NGRP,MAX1D),GAR2(NMIX,MAXNFI,NGRP,MAX2D), 1 GAR3(NMIX,NGRP,NGRP,MAXNL),GAR4(NMIX*NGRP),GAR4B(NMIL*NGRP), 2 ADF2(NMIX,NGRP,NSURFD),FMASL(NMIX),FMASLB(NMIX)) ALLOCATE(HADF(NSURFD)) *---- * MACROLIB INITIALIZATION *---- CALL LCMGET(IPMEM,'DIMSAP',DIMSAP) IF(DIMSAP(7).NE.NMIL) THEN CALL XABORT('SCRSAP: INVALID NUMBER OF MIXTURES(1).') ELSE IF(DIMSAP(19).NE.NCAL) THEN CALL XABORT('SCRSAP: INVALID NUMBER OF CALCULATIONS(1).') ELSE IF(DIMSAP(20).NE.NGRP) THEN CALL XABORT('SCRSAP: INVALID NUMBER OF ENERGY GROUPS(1).') ENDIF LMAKE1(:MAX1D)=.FALSE. LMAKE2(:MAX2D)=.FALSE. GAR1(:NMIX,:NGRP,:MAX1D)=0.0 GAR2(:NMIX,:MAXNFI,:NGRP,:MAX2D)=0.0 GAR3(:NMIX,:NGRP,:NGRP,:MAXNL)=0.0 FMASL(:NMIX)=0.0 IF(NSURFD.GT.0) ADF2(:NMIX,:NGRP,:NSURFD)=0.0 ALLOCATE(XVOLM(NMIX),ENERG(NGRP+1)) XVOLM(:NMIX)=0.0 ENERG(:NGRP+1)=0.0 IBMOLD=0 N1D=0 N2D=0 NDEL=0 NL=0 NF=0 NED=0 ITRANC=0 IDF=0 N1D=0 N2D=0 *---- * READ EXISTING MACROLIB INFORMATION *---- IF(IACCS.EQ.0) THEN TEXT12='L_MACROLIB' CALL LCMPTC(IPMAC,'SIGNATURE',12,TEXT12) ELSE CALL LCMGTC(IPMAC,'SIGNATURE',12,TEXT12) IF(TEXT12.NE.'L_MACROLIB') THEN CALL XABORT('SCRSAP: SIGNATURE OF INPUT MACROLIB IS '//TEXT12 1 //'. L_MACROLIB EXPECTED.') ENDIF CALL LCMGET(IPMAC,'STATE-VECTOR',ISTATE) IF(ISTATE(1).NE.NGRP) THEN CALL XABORT('SCRSAP: INVALID NUMBER OF ENERGY GROUPS(2).') ELSE IF(ISTATE(2).NE.NMIX) THEN CALL XABORT('SCRSAP: INVALID NUMBER OF MIXTURES(2).') ENDIF NL=ISTATE(3) NF=ISTATE(4) IF(NF.GT.MAXNFI) CALL XABORT('SCRSAP: MAXNFI OVERFLOW(1).') NED=ISTATE(5) ITRANC=ISTATE(6) NDEL=ISTATE(7) IDF=ISTATE(12) IF(NED.GT.MAXED) CALL XABORT('SCRSAP: MAXED OVERFLOW(1).') CALL LCMGTC(IPMAC,'ADDXSNAME-P0',8,NED,HVECT) N1D=8+NED+NL N2D=2*(NDEL+1) IF(NL.GT.MAXNL) CALL XABORT('SCRSAP: MAXNL OVERFLOW(1).') IF(N1D.GT.MAX1D) CALL XABORT('SCRSAP: MAX1D OVERFLOW(1).') IF(N2D.GT.MAX2D) CALL XABORT('SCRSAP: MAX2D OVERFLOW(1).') DO 20 IED=1,NED HMAK1(8+IED)=HVECT(IED) 20 CONTINUE DO 30 IL=1,NL WRITE(CM,'(I2.2)') IL-1 HMAK1(8+NED+IL)='SIGS'//CM 30 CONTINUE HMAK2(1)='NUSIGF' HMAK2(2)='CHI' DO 40 IDEL=1,NDEL WRITE(TEXT8,'(6HNUSIGF,I2.2)') IDEL HMAK2(2+2*(IDEL-1)+1)=TEXT8 WRITE(TEXT8,'(3HCHI,I2.2)') IDEL HMAK2(2+2*(IDEL-1)+2)=TEXT8 40 CONTINUE CALL LCMGET(IPMAC,'STATE-VECTOR',ISTATE) CALL LCMGET(IPMAC,'VOLUME',XVOLM) JPMAC=LCMGID(IPMAC,'GROUP') DO 105 IGR=1,NGRP KPMAC=LCMGIL(JPMAC,IGR) DO 60 I1D=1,N1D CALL LCMLEN(KPMAC,HMAK1(I1D),ILONG,ITYLCM) IF(ILONG.NE.0) THEN LMAKE1(I1D)=.TRUE. CALL LCMGET(KPMAC,HMAK1(I1D),GAR1(1,IGR,I1D)) DO 55 IBM=1,NMIX DO 50 IBMOLD=1,NMIL IF(MIXC(IBM).EQ.IBMOLD) GAR1(IBM,IGR,I1D)=0.0 50 CONTINUE 55 CONTINUE ENDIF 60 CONTINUE DO 80 I2D=1,N2D CALL LCMLEN(KPMAC,HMAK2(I2D),ILONG,ITYLCM) IF(ILONG.NE.0) THEN LMAKE2(I2D)=.TRUE. CALL LCMGET(KPMAC,HMAK2(I2D),GAR2(1,1,IGR,I2D)) DO 72 I=1,NF DO 71 IBM=1,NMIX DO 70 IBMOLD=1,NMIL IF(MIXC(IBM).EQ.IBMOLD) GAR2(IBM,I,IGR,I2D)=0.0 70 CONTINUE 71 CONTINUE 72 CONTINUE ENDIF 80 CONTINUE DO 100 IL=1,NL WRITE(CM,'(I2.2)') IL-1 ILONG=1 IF(IL.GT.1) CALL LCMLEN(KPMAC,'SCAT'//CM,ILONG,ITYLCM) IF(ILONG.NE.0) THEN CALL LCMGET(KPMAC,'SCAT'//CM,GAR4) CALL LCMGET(KPMAC,'NJJS'//CM,NJJ) CALL LCMGET(KPMAC,'IJJS'//CM,IJJ) CALL LCMGET(KPMAC,'IPOS'//CM,IPOS) DO 95 IBM=1,NMIX IPOSDE=IPOS(IBM) DO 90 JGR=IJJ(IBM),IJJ(IBM)-NJJ(IBM)+1,-1 GAR3(IBM,JGR,IGR,IL)=GAR4(IPOSDE) DO 85 IBMOLD=1,NMIL IF(MIXC(IBM).EQ.IBMOLD) GAR3(IBM,JGR,IGR,IL)=0.0 85 CONTINUE IPOSDE=IPOSDE+1 90 CONTINUE 95 CONTINUE ENDIF 100 CONTINUE 105 CONTINUE IF(IDF.EQ.2) THEN CALL LCMSIX(IPMAC,'ADF',1) CALL LCMGTC(IPMAC,'HADF',8,NSURFD,HADF) DO ITYPE=1,NSURFD CALL LCMGET(IPMAC,HADF(ITYPE),ADF2(1,1,ITYPE)) ENDDO CALL LCMSIX(IPMAC,' ',2) ENDIF ENDIF *---- * OVERALL ELEMENTARY CALCULATION LOOP *---- DO 210 ICAL=1,NCAL DO 110 IBM=1,NMIX ! mixtures in Macrolib WEIGHT=TERP(ICAL,IBM) IF(WEIGHT.NE.0.0) GO TO 120 110 CONTINUE GO TO 210 *---- * PRODUCE AN ELEMENTARY MACROLIB (IF IPTMP=0) *---- 120 CALL LCMOP(IPTMP,'*ELEMENTARY*',0,1,0) ALLOCATE(SPH(NMIL,NGRP)) B2R=B2 CALL SCRSPH(IPMEM,IPTMP,ICAL,IMPX,HEQUI,HMASL,NMIL,NGRP,ILUPS, 1 SPH,B2R) *---- * RECOVER MACROLIB PARAMETERS *---- CALL LCMGET(IPTMP,'STATE-VECTOR',ISTATE) NLTMP=ISTATE(3) NFTMP=ISTATE(4) NEDTMP=ISTATE(5) IF(NLTMP.GT.MAXNL) CALL XABORT('SCRMAC: MAXNL OVERFLOW(2).') IF(NFTMP.GT.MAXNFI) CALL XABORT('SCRMAC: MAXNFI OVERFLOW(2).') IF(NEDTMP.GT.MAXED) CALL XABORT('SCRMAC: MAXED OVERFLOW(2).') IF(IACCS.EQ.0) THEN IF(ISTATE(1).NE.NGRP) THEN CALL XABORT('SCRSAP: INVALID NUMBER OF ENERGY GROUPS(3).') ELSE IF(ISTATE(2).NE.NMIL) THEN CALL XABORT('SCRSAP: INVALID NUMBER OF MIXTURES(3).') ENDIF NL=NLTMP NF=NFTMP NED=NEDTMP ITRANC=ISTATE(6) NDEL=ISTATE(7) IDF=ISTATE(12) CALL LCMGTC(IPTMP,'ADDXSNAME-P0',8,NED,HVECT) N1D=8+NED+NL N2D=2*(NDEL+1) IF(N1D.GT.MAX1D) CALL XABORT('SCRSAP: MAX1D OVERFLOW(2).') IF(N2D.GT.MAX2D) CALL XABORT('SCRSAP: MAX2D OVERFLOW(2).') DO 130 IED=1,NED HMAK1(8+IED)=HVECT(IED) 130 CONTINUE DO 140 IL=1,NL WRITE(CM,'(I2.2)') IL-1 HMAK1(8+NED+IL)='SIGS'//CM 140 CONTINUE HMAK2(1)='NUSIGF' HMAK2(2)='CHI' DO 150 IDEL=1,NDEL WRITE(TEXT8,'(6HNUSIGF,I2.2)') IDEL HMAK2(2+2*(IDEL-1)+1)=TEXT8 WRITE(TEXT8,'(3HCHI,I2.2)') IDEL HMAK2(2+2*(IDEL-1)+2)=TEXT8 150 CONTINUE ELSE IF(NLTMP.GT.NL) CALL XABORT('SCRMAC: NL OVERFLOW.') ITRANC=MAX(ITRANC,ISTATE(6)) IF(ISTATE(1).NE.NGRP) THEN CALL XABORT('SCRSAP: INVALID NUMBER OF ENERGY GROUPS(3).') ELSE IF(ISTATE(2).NE.NMIL)THEN CALL XABORT('SCRSAP: INVALID NUMBER OF MIXTURES(3).') ELSE IF(ISTATE(5).NE.NED) THEN CALL XABORT('SCRSAP: INVALID NUMBER OF EDIT REACTIONS(3).') ELSE IF((NFTMP.NE.0).AND.(NFTMP.NE.NF)) THEN CALL XABORT('SCRSAP: INVALID NUMBER OF FISSILE ISOTOPES(3).') ELSE IF(ISTATE(7).NE.NDEL) THEN CALL XABORT('SCRSAP: INVALID NUMBER OF PRECURSOR GROUPS(3).') ELSE IF(ISTATE(12).NE.IDF) THEN CALL XABORT('SCRSAP: INVALID TYPE OF ADF DIRECTORY.') ENDIF ENDIF *---- * SPH CORRECTION OF MACROLIB INFORMATION *---- IMC=1 ! SPH correction for SPN macro-calculation NALBP=0 ! no albedo correction CALL SPHCMA(IPTMP,IMPX,IMC,NMIL,NGRP,NFTMP,NEDTMP,NALBP,SPH) DEALLOCATE(SPH) *---- * RECOVER KEFF, VOLUMES, ENERGY GROUPS, EDIT NAMES, AND LAMBDA-D. *---- CALL LCMLEN(IPTMP,'K-EFFECTIVE',IKEFF,ITYLCM) IF(IKEFF.EQ.1) CALL LCMGET(IPTMP,'K-EFFECTIVE',FKEFF) CALL LCMLEN(IPTMP,'VOLUME',ILONG,ITYLCM) IF(ILONG.EQ.NMIL) THEN ALLOCATE(VOSAP(NMIL)) CALL LCMGET(IPTMP,'VOLUME',VOSAP) DO 160 IBM=1,NMIX ! mixtures in Macrolib IBMOLD=MIXC(IBM) ! mixture in Saphyb IF(IBMOLD.NE.0) XVOLM(IBM)=VOSAP(IBMOLD) 160 CONTINUE DEALLOCATE(VOSAP) ENDIF CALL LCMLEN(IPTMP,'ENERGY',ILONG,ITYLCM) IF(ILONG.EQ.NGRP+1) CALL LCMGET(IPTMP,'ENERGY',ENERG) CALL LCMLEN(IPTMP,'LAMBDA-D',LENGTH,ITYLCM) LWD=(LENGTH.EQ.NDEL).AND.(NDEL.GT.0) IF(LWD) THEN ALLOCATE(WDLA(NDEL)) CALL LCMGET(IPTMP,'LAMBDA-D',WDLA) CALL LCMPUT(IPMAC,'LAMBDA-D',NDEL,2,WDLA) DEALLOCATE(WDLA) ENDIF *---- * RECOVER MASL INFORMATION *---- IF(HMASL.NE.' ') CALL LCMGET(IPTMP,'MASL',FMASLB) *---- * PERFORM INTERPOLATION *---- JPTMP=LCMGID(IPTMP,'GROUP') DO 200 IBM=1,NMIX ! mixtures in Macrolib WEIGHT=TERP(ICAL,IBM) IF(WEIGHT.EQ.0.0) GO TO 200 IBMOLD=MIXC(IBM) ! mixture in Saphyb IF(IBMOLD.EQ.0) GO TO 200 IF(HMASL.NE.' ') FMASL(IBM)=FMASL(IBM)+WEIGHT*FMASLB(IBMOLD) * DO 195 IGR=1,NGRP KPTMP=LCMGIL(JPTMP,IGR) DO 170 I1D=1,N1D CALL LCMLEN(KPTMP,HMAK1(I1D),ILONG,ITYLCM) IF(ILONG.NE.0) THEN LMAKE1(I1D)=.TRUE. CALL LCMGPD(KPTMP,HMAK1(I1D),FLOT_PTR) CALL C_F_POINTER(FLOT_PTR,FLOT,(/ ILONG /)) FLOTVA=FLOT(IBMOLD) IF((.NOT.LPURE).AND.(I1D.EQ.4)) FLOTVA=1.0/FLOTVA GAR1(IBM,IGR,I1D)=GAR1(IBM,IGR,I1D)+WEIGHT*FLOTVA ENDIF 170 CONTINUE IF(ISTATE(4).GT.0) THEN DO 175 I2D=1,N2D CALL LCMLEN(KPTMP,HMAK2(I2D),ILONG,ITYLCM) IF(ILONG.NE.0) THEN LMAKE2(I2D)=.TRUE. CALL LCMGPD(KPTMP,HMAK2(I2D),FLOT_PTR) CALL C_F_POINTER(FLOT_PTR,FLOT,(/ ILONG /)) DO 174 I=1,NF IOF=(IBMOLD-1)*NF+I GAR2(IBM,I,IGR,I2D)=GAR2(IBM,I,IGR,I2D)+WEIGHT*FLOT(IOF) 174 CONTINUE ENDIF 175 CONTINUE ENDIF DO 190 IL=1,NLTMP WRITE(CM,'(I2.2)') IL-1 ILONG=1 IF(IL.GT.1) CALL LCMLEN(KPTMP,'SCAT'//CM,ILONG,ITYLCM) IF(ILONG.NE.0) THEN CALL LCMGET(KPTMP,'SCAT'//CM,GAR4B) CALL LCMGET(KPTMP,'NJJS'//CM,NJJB) CALL LCMGET(KPTMP,'IJJS'//CM,IJJB) CALL LCMGET(KPTMP,'IPOS'//CM,IPOSB) IPOSDE=IPOSB(IBMOLD) DO 180 JGR=IJJB(IBMOLD),IJJB(IBMOLD)-NJJB(IBMOLD)+1,-1 GAR3(IBM,JGR,IGR,IL)=GAR3(IBM,JGR,IGR,IL)+WEIGHT*GAR4B(IPOSDE) IPOSDE=IPOSDE+1 180 CONTINUE ENDIF 190 CONTINUE 195 CONTINUE *---- * PROCESS ADF INFORMATION *---- IF(IDF.EQ.2) THEN CALL LCMSIX(IPTMP,'ADF',1) CALL LCMGET(IPTMP,'NTYPE',NTYPE) IF(NTYPE.NE.NSURFD) CALL XABORT('SCRSAP: INVALID NTYPE VALUE.') CALL LCMGTC(IPTMP,'HADF',8,NSURFD,HADF) DO ITYPE=1,NSURFD CALL LCMGET(IPTMP,HADF(ITYPE),GAR4) DO IGR=1,NGRP ADF2(IBM,IGR,ITYPE)=ADF2(IBM,IGR,ITYPE)+WEIGHT*GAR4(IGR) ENDDO ENDDO CALL LCMSIX(IPTMP,' ',2) ENDIF 200 CONTINUE CALL LCMCL(IPTMP,2) 210 CONTINUE *---- * WRITE INTERPOLATED MACROLIB INFORMATION *---- IF(IKEFF.EQ.1) CALL LCMPUT(IPMAC,'K-EFFECTIVE',1,2,FKEFF) CALL LCMPUT(IPMAC,'VOLUME',NMIX,2,XVOLM) CALL LCMPUT(IPMAC,'ENERGY',NGRP+1,2,ENERG) IF(HMASL.NE.' ') CALL LCMPUT(IPMAC,'MASL',NMIX,2,FMASL) DEALLOCATE(ENERG,XVOLM) IF(NED.GT.0) CALL LCMPTC(IPMAC,'ADDXSNAME-P0',8,NED,HVECT) JPMAC=LCMLID(IPMAC,'GROUP',NGRP) DO 365 IGR=1,NGRP KPMAC=LCMDIL(JPMAC,IGR) DO 320 I1D=1,N1D IF(LMAKE1(I1D)) THEN IF((.NOT.LPURE).AND.(I1D.EQ.4)) THEN DO 311 IBM=1,NMIX DO 310 IBMOLD=1,NMIL IF(MIXC(IBM).EQ.IBMOLD) GAR1(IBM,IGR,I1D)=1./GAR1(IBM,IGR,I1D) 310 CONTINUE 311 CONTINUE ELSE IF(I1D.EQ.7) THEN DO 316 IBM=1,NMIX DO 315 IBMOLD=1,NMIL IF(MIXC(IBM).EQ.IBMOLD) GAR1(IBM,IGR,I1D)=GAR1(IBM,IGR,I1D)* 1 1.0E6 ! convert MeV to eV 315 CONTINUE 316 CONTINUE ENDIF CALL LCMPUT(KPMAC,HMAK1(I1D),NMIX,2,GAR1(1,IGR,I1D)) ENDIF 320 CONTINUE DO 325 I2D=1,N2D IF(LMAKE2(I2D).AND.(NF.GT.0)) THEN CALL LCMPUT(KPMAC,HMAK2(I2D),NMIX*NF,2,GAR2(1,1,IGR,I2D)) ENDIF 325 CONTINUE DO 360 IL=1,NL WRITE(CM,'(I2.2)') IL-1 IPOSDE=0 DO 350 IBM=1,NMIX IPOS(IBM)=IPOSDE+1 IGMIN=IGR IGMAX=IGR DO 330 JGR=1,NGRP IF(GAR3(IBM,JGR,IGR,IL).NE.0.0) THEN IGMIN=MIN(IGMIN,JGR) IGMAX=MAX(IGMAX,JGR) ENDIF 330 CONTINUE IJJ(IBM)=IGMAX NJJ(IBM)=IGMAX-IGMIN+1 DO 340 JGR=IGMAX,IGMIN,-1 IPOSDE=IPOSDE+1 GAR4(IPOSDE)=GAR3(IBM,JGR,IGR,IL) 340 CONTINUE 350 CONTINUE IF(IPOSDE.GT.0) THEN CALL LCMPUT(KPMAC,'SCAT'//CM,IPOSDE,2,GAR4) CALL LCMPUT(KPMAC,'NJJS'//CM,NMIX,1,NJJ) CALL LCMPUT(KPMAC,'IJJS'//CM,NMIX,1,IJJ) CALL LCMPUT(KPMAC,'IPOS'//CM,NMIX,1,IPOS) CALL LCMPUT(KPMAC,'SIGW'//CM,NMIX,2,GAR3(1,IGR,IGR,IL)) ENDIF 360 CONTINUE 365 CONTINUE IF(IDF.EQ.2) THEN CALL LCMSIX(IPMAC,'ADF',1) CALL LCMPUT(IPMAC,'NTYPE',1,1,NSURFD) CALL LCMPTC(IPMAC,'HADF',8,NSURFD,HADF) DO ITYPE=1,NSURFD CALL LCMPUT(IPMAC,HADF(ITYPE),NMIX*NGRP,2,ADF2(1,1,ITYPE)) ENDDO CALL LCMSIX(IPMAC,' ',2) ENDIF IACCS=1 *---- * UPDATE STATE-VECTOR *---- ISTATE(2)=NMIX ISTATE(3)=NL ISTATE(4)=NF ISTATE(5)=NED ISTATE(6)=ITRANC IF(LMAKE1(6)) ISTATE(10)=1 CALL LCMPUT(IPMAC,'STATE-VECTOR',NSTATE,1,ISTATE) *---- * INCLUDE LEAKAGE IN THE MACROLIB (USED ONLY FOR NON-REGRESSION TESTS) *---- IF(B2.NE.0.0) THEN IF(IMPX.GT.0) WRITE(IOUT,'(/31H SCRSAP: INCLUDE LEAKAGE IN THE, 1 14H MACROLIB (B2=,1P,E12.5,2H).)') B2 JPMAC=LCMGID(IPMAC,'GROUP') ALLOCATE(WORK1(NMIX),WORK2(NMIX)) DO 520 IGR=1,NGRP KPMAC=LCMGIL(JPMAC,IGR) CALL LCMGET(KPMAC,'NTOT0',WORK1) CALL LCMGET(KPMAC,'DIFF',WORK2) DO 510 IBM=1,NMIX IF(MIXC(IBM).NE.0) WORK1(IBM)=WORK1(IBM)+B2*WORK2(IBM) 510 CONTINUE CALL LCMPUT(KPMAC,'NTOT0',NMIX,2,WORK1) 520 CONTINUE DEALLOCATE(WORK2,WORK1) ENDIF *---- * SCRATCH STORAGE DEALLOCATION *---- DEALLOCATE(HADF) DEALLOCATE(FMASLB,FMASL,ADF2,GAR4B,GAR4,GAR3,GAR2,GAR1) DEALLOCATE(IPOSB,NJJB,IJJB,IPOS,NJJ,IJJ) RETURN END