diff options
Diffstat (limited to 'Dragon/src/COMGEP.f')
| -rw-r--r-- | Dragon/src/COMGEP.f | 383 |
1 files changed, 383 insertions, 0 deletions
diff --git a/Dragon/src/COMGEP.f b/Dragon/src/COMGEP.f new file mode 100644 index 0000000..7a0cb81 --- /dev/null +++ b/Dragon/src/COMGEP.f @@ -0,0 +1,383 @@ +*DECK COMGEP + SUBROUTINE COMGEP(IPCPO,IPDEPL,IPLB1,IPLB2,IPEDIT,IMPX,ITIM,NORIG, + 1 NPAR,NLOC,NMIL,MUPLET,LGNEW) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover remaining global and local parameters. Update the parameter +* tree (in each mixture) for a new elementary calculation. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPCPO pointer to the multicompo. +* IPDEPL pointer to the burnup object. +* IPLB1 pointer to the first microlib object. +* IPLB2 pointer to the second (optional) microlib object. +* IPEDIT pointer to the edition object. +* IMPX print parameter. +* ITIM index of the current burnup step. +* NORIG index of the elementary calculation associated to the +* father node in the parameter tree. +* NPAR number of global parameters. +* NLOC number of local parameters. +* NMIL number of homogenized mixtures. +* MUPLET tuple of indices associated to each global parameter of the +* elementary calculation. +* LGNEW parameter modification flag (=.true. if the I-th global +* parameter has changed in the new elementary calculation). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPCPO,IPDEPL,IPLB1,IPLB2,IPEDIT + INTEGER IMPX,ITIM,NORIG,NPAR,NLOC,NMIL,MUPLET(NPAR) + LOGICAL LGNEW(NPAR) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40,MAXPAR=50) + TYPE(C_PTR) JPCPO,KPCPO,IPLB3 + INTEGER ISTATE(NSTATE),PARMIL(MAXPAR),PARCAD(MAXPAR+1), + 1 PARPAD(MAXPAR+1),NVPO(2) + CHARACTER PARKEY(MAXPAR)*12,PARCHR(MAXPAR)*8,PARTYP(MAXPAR)*4, + 1 PARBIB(MAXPAR)*12,TEXT4*4,TEXT8*8,TEXT12*12,NAMLCM*12,NAMMY*12 + LOGICAL LGERR,EMPTY,LCM,COMTRE,LAST +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IDEBAR,IARBVA,JDEBAR,JARBVA, + 1 IORIGI + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: MUPL2 + REAL, ALLOCATABLE, DIMENSION(:,:) :: RVALO + LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: LGNE2 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(MUPL2(NPAR+NLOC,NMIL),LGNE2(NPAR+NLOC,NMIL)) +*---- +* RECOVER INFORMATION FROM THE 'STATE-VECTOR' PARAMETER LIST +*---- + CALL LCMGET(IPCPO,'STATE-VECTOR',ISTATE) + IF(NPAR.NE.ISTATE(5)) CALL XABORT('COMGEP: WRONG VALUE OF NPAR.') + IF(NLOC.NE.ISTATE(6)) CALL XABORT('COMGEP: WRONG VALUE OF NLOC.') + NMIL=ISTATE(1) + NG=ISTATE(2) + NCAL=ISTATE(3) + MAXCAL=ISTATE(4) + NPCHR=ISTATE(7) + NPPNT=ISTATE(8) + NPCHRL=ISTATE(9) +*---- +* RECOVER INFORMATION FROM THE 'GLOBAL' DIRECTORY +*---- + CALL LCMSIX(IPCPO,'GLOBAL',1) + IF(NPAR.GT.0) CALL LCMGTC(IPCPO,'PARKEY',12,NPAR,PARKEY) + IF(NPAR.GT.0) CALL LCMGTC(IPCPO,'PARTYP',4,NPAR,PARTYP) + CALL LCMGET(IPCPO,'PARCAD',PARCAD) + CALL LCMGET(IPCPO,'PARPAD',PARPAD) + IF(NPCHR.GT.0) CALL LCMGTC(IPCPO,'PARCHR',8,NPCHR,PARCHR) + IF(NPPNT.GT.0) CALL LCMGET(IPCPO,'PARMIL',PARMIL) + IF(NPPNT.GT.0) CALL LCMGTC(IPCPO,'PARBIB',12,NPPNT,PARBIB) + CALL LCMSIX(IPCPO,' ',2) +*---- +* RECOVER REMAINING GLOBAL PARAMETERS +*---- + DO 10 IPAR=1,NPAR + IF(PARTYP(IPAR).EQ.'VALU') THEN + GO TO 10 + ELSE IF(LGNEW(IPAR)) THEN + CALL XABORT('COMGEP: PARAMETER '//PARTYP(IPAR)//' IS ALREADY D' + 1 //'EFINED (REMOVE THE '//PARKEY(IPAR)//' KEYWORD).') + ELSE IF((PARTYP(IPAR).EQ.'IRRA').OR.(PARTYP(IPAR).EQ.'TIME').OR. + 1 (PARTYP(IPAR).EQ.'POWR').OR.(PARTYP(IPAR).EQ.'FLUB').OR. + 2 (PARTYP(IPAR).EQ.'FLUX').OR.(PARTYP(IPAR).EQ.'MASL')) THEN +* +* RECOVER GLOBAL PARAMETER VALUES FROM THE BURNUP OBJECT. + IF(.NOT.C_ASSOCIATED(IPDEPL)) THEN + CALL XABORT('COMGEP: NO DEPLETION OBJECT AVAILABLE AMONG T' + 1 //'HE RHS LCM OBJECTS.') + ENDIF + CALL LCMGET(IPDEPL,'STATE-VECTOR',ISTATE) + NBURN=ISTATE(3) + NBISO=ISTATE(4) + NREAC=ISTATE(6) + NVAR=ISTATE(7) + NBMIX=ISTATE(8) + CALL COMGEM(IPDEPL,ITIM,PARTYP(IPAR),0,NBURN,NBMIX,NBISO, + 1 NREAC,NVAR,VALPAR) + ELSE IF((PARTYP(IPAR).EQ.'TEMP').OR.(PARTYP(IPAR).EQ.'CONC')) + 1 THEN +* +* RECOVER GLOBAL PARAMETER VALUES FROM A MICROLIB OBJECT. + IF(.NOT.C_ASSOCIATED(IPLB1)) THEN + CALL XABORT('COMGEP: MICROLIB EXPECTED AT RHS.') + ENDIF + IPCAD=PARCAD(IPAR+1)-PARCAD(IPAR) + IPPAD=PARPAD(IPAR+1)-PARPAD(IPAR) + IF(IPCAD.EQ.1) IPCAD=PARCAD(IPAR+1)-PARCAD(1) + IF(IPPAD.EQ.1) IPPAD=PARPAD(IPAR+1)-PARPAD(1) + TEXT8=' ' + TEXT12=' ' + IMILI=0 + IF(IPCAD.GT.0) TEXT8=PARCHR(IPCAD) + IF(IPPAD.GT.0) TEXT12=PARBIB(IPPAD) + IF(IPPAD.GT.0) IMILI=PARMIL(IPPAD) + CALL LCMGET(IPLB1,'STATE-VECTOR',ISTATE) + MAXNBI=ISTATE(2) + IF(C_ASSOCIATED(IPLB2)) THEN + CALL LCMGET(IPLB2,'STATE-VECTOR',ISTATE) + MAXNBI=MAX(MAXNBI,ISTATE(2)) + ENDIF + CALL COMBIB(IPLB1,IPLB2,PARTYP(IPAR),IMILI,TEXT12,TEXT8,MAXNBI, + 1 VALPAR) + ELSE + CALL XABORT('COMGEP: '//PARTYP(IPAR)//' IS AN UNKNOWN PARAM'// + 1 'ETER TYPE.') + ENDIF + IF(IMPX.GT.0) WRITE(6,100) PARKEY(IPAR),VALPAR +* + CALL LCMSIX(IPCPO,'GLOBAL',1) + TEXT8='REAL' + CALL COMPAV(IPCPO,IPAR,NPAR,TEXT8,VALPAR,NITMA,TEXT12, + 1 MUPLET(IPAR),LGNEW(IPAR)) + CALL LCMSIX(IPCPO,' ',2) + 10 CONTINUE + DO 25 IBM=1,NMIL + DO 20 IPAR=1,NPAR + MUPL2(IPAR,IBM)=MUPLET(IPAR) + LGNE2(IPAR,IBM)=LGNEW(IPAR) + 20 CONTINUE + 25 CONTINUE + IF(NLOC.EQ.0) GO TO 50 +*---- +* RECOVER INFORMATION FROM THE 'LOCAL' DIRECTORY +*---- + CALL LCMSIX(IPCPO,'LOCAL',1) + CALL LCMGTC(IPCPO,'PARKEY',12,NLOC,PARKEY) + CALL LCMGTC(IPCPO,'PARTYP',4,NLOC,PARTYP) + CALL LCMGET(IPCPO,'PARCAD',PARCAD) + IF(NPCHRL.GT.0) CALL LCMGTC(IPCPO,'PARCHR',8,NPCHRL,PARCHR) + CALL LCMSIX(IPCPO,' ',2) +*---- +* RECOVER LOCAL PARAMETERS +*---- + CALL LCMGTC(IPEDIT,'LAST-EDIT',12,TEXT12) + ALLOCATE(RVALO(NLOC,NMIL)) + DO 45 IPAR=1,NLOC + IF((PARTYP(IPAR).EQ.'IRRA').OR.(PARTYP(IPAR).EQ.'TIME').OR. + 1 (PARTYP(IPAR).EQ.'POWR').OR.(PARTYP(IPAR).EQ.'FLUG').OR. + 2 (PARTYP(IPAR).EQ.'FLUB').OR.(PARTYP(IPAR).EQ.'FLUX').OR. + 3 (PARTYP(IPAR).EQ.'MASL')) THEN +* +* RECOVER LOCAL PARAMETERS FROM THE BURNUP OBJECT. + CALL LCMGET(IPDEPL,'STATE-VECTOR',ISTATE) + NBURN=ISTATE(3) + NBISO=ISTATE(4) + NREAC=ISTATE(6) + NVAR=ISTATE(7) + NBMIX=ISTATE(8) + IF(.NOT.C_ASSOCIATED(IPDEPL)) THEN + CALL XABORT('COMGEP: NO DEPLETION OBJECT AVAILABLE AMONG T' + 1 //'HE RHS LCM OBJECTS.') + ENDIF + CALL LCMGET(IPEDIT,'STATE-VECTOR',ISTATE) + NREG=ISTATE(17) + CALL COMGEN(IPDEPL,IPEDIT,NREG,NMIL,ITIM,PARTYP(IPAR),NBURN, + 1 NBMIX,NBISO,NREAC,NVAR,IPAR,NLOC,RVALO) + ELSE IF((PARTYP(IPAR).EQ.'TEMP').OR.(PARTYP(IPAR).EQ.'CONC')) + 1 THEN +* +* RECOVER LOCAL PARAMETERS FROM THE MICROLIB IN EDIT OBJECT. + IPCAD=PARCAD(IPAR+1)-PARCAD(IPAR) + IF(IPCAD.EQ.1) IPCAD=PARCAD(IPAR+1)-PARCAD(1) + TEXT8=' ' + IF(IPCAD.GT.0) TEXT8=PARCHR(IPCAD) + CALL LCMSIX(IPEDIT,TEXT12,1) + CALL LCMGET(IPEDIT,'STATE-VECTOR',ISTATE) + MAXNBI=ISTATE(2) + CALL LCMINF(IPEDIT,NAMLCM,NAMMY,EMPTY,ILONG,LCM) + IPLB3=C_NULL_PTR + DO 30 IBM=1,NMIL + CALL COMBIB(IPEDIT,IPLB3,PARTYP(IPAR),IBM,NAMLCM,TEXT8,MAXNBI, + 1 VALPAR) + RVALO(IPAR,IBM)=VALPAR + 30 CONTINUE + CALL LCMSIX(IPEDIT,' ',2) + ELSE + CALL XABORT('COMGEP: '//PARTYP(IPAR)//' IS AN UNKNOWN LOCAL'// + 1 ' PARAMETER TYPE.') + ENDIF + IF(IMPX.GT.1) THEN + WRITE(6,120) PARKEY(IPAR),(RVALO(IPAR,IBM),IBM=1,NMIL) + ENDIF + JPCPO=LCMLID(IPCPO,'MIXTURES',NMIL) + DO 40 IBM=1,NMIL + KPCPO=LCMDIL(JPCPO,IBM) + CALL LCMSIX(KPCPO,'TREE',1) + FLOTT=RVALO(IPAR,IBM) + TEXT8='REAL' + CALL COMPAV(KPCPO,IPAR,NLOC,TEXT8,FLOTT,NITMA,TEXT12, + 1 MUPL2(NPAR+IPAR,IBM),LGNE2(NPAR+IPAR,IBM)) + CALL LCMSIX(KPCPO,' ',2) + 40 CONTINUE + 45 CONTINUE + DEALLOCATE(RVALO) +*---- +* UPDATE THE PARAMETER TREE IN EACH MIXTURE COMPONENT +*---- + 50 JPCPO=LCMLID(IPCPO,'MIXTURES',NMIL) + DO 90 IBM=1,NMIL + IF(IMPX.GT.4) THEN + WRITE(6,'(/17H COMGEP: MIXTURE=,I6)') IBM + WRITE(6,110) (MUPL2(I,IBM),I=1,NPAR+NLOC) + WRITE(6,'(/)') + ENDIF + DO 55 I=1,NPAR+NLOC + IF(MUPL2(I,IBM).EQ.0) THEN + WRITE(6,'(/17H COMGEP: MIXTURE=,I6,23H, UNDEFINED MUPLET ELEM, + 1 4HENT=,I6)') IBM,I + CALL XABORT('COMGEP: A MUPLET ELEMENT IS NOT ASSIGNED.') + ENDIF + 55 CONTINUE + KPCPO=LCMDIL(JPCPO,IBM) +** +** Parameter tree: this tree has a number of stages equal to the +** number of parameters. For each value of the i-th parameter, we +** find the position in the tree corresponding to the value of the +** (i+1)-th parameter. +** NCALAR Number of elementary calculations stored in the tree. +** NVPO(1) Number of nodes in the parameter tree, including the root. +** The value corresponding to the root is not used. +** DEBARB - If the node does not correspond to the last parameter: +** index in DEBARB of the first daughter of the node. +** - If the node correspond to the last parameter: index in +** DEBARB where we recover the index of an elementary +** calculation. +** ARBVAL Index of the corresponding parameter in the 'pval'//n +** record. +* +** EXEMPLE: dn = value in DEBARB, (m) = value in ARBVAL +** +** Root *(0) +** ! +** Param. Nb 1 d2(1) +** ------------------- +** ! ! +** Param. Nb 2 d3(1) 4(2) +** --------- --------- +** ! ! ! ! ! +** Param. Nb 3 d5(1) 6(3) d7(1) 8(2) 9(3) d10 +** +** Calculation Nb: 4 5 1 2 3 +** +** DEBARB: 2 3 5 7 10 4 5 1 2 3 +** ARBVAL: 0 1 1 2 1 3 1 2 3 +* + CALL LCMSIX(KPCPO,'TREE',1) + CALL LCMLEN(KPCPO,'NVP',ILONG,ITYLCM) + IF(ILONG.EQ.0) THEN + MAXNVP=20*(NPAR+NLOC+1) + ALLOCATE(IDEBAR(MAXNVP+1),IARBVA(MAXNVP)) + IDEBAR(:MAXNVP+1)=0 + IARBVA(:MAXNVP)=0 + IARBVA=0 + DO 60 I=1,NPAR+NLOC + IDEBAR(I)=I+1 + IARBVA(I+1)=1 + 60 CONTINUE + IDEBAR(NPAR+NLOC+1)=NPAR+NLOC+2 + IDEBAR(NPAR+NLOC+2)=1 + NCALAR=1 + NVPNEW=NPAR+NLOC+1 + ELSE +* +* Find position of the new point and create new PARBRE. +* +* "II" is the order number of first parameter which recives a +* "brand new" value. +* COMTRE returns .TRUE. if the sweep throught the tree reaches +* its bottom, otherwise it returns "KK" value: level of the +* first new node to be introduced. +* + CALL LCMGET(KPCPO,'NVP',NVPO) + MAXNVP=NVPO(2) + ALLOCATE(JDEBAR(NVPO(1)+1),JARBVA(NVPO(1))) + CALL LCMGET(KPCPO,'NCALS',NCALAR) + CALL LCMGET(KPCPO,'DEBARB',JDEBAR) + CALL LCMGET(KPCPO,'ARBVAL',JARBVA) + DO 70 IPAR=1,NPAR+NLOC + IF(LGNE2(IPAR,IBM)) THEN + II=IPAR + GO TO 80 + ENDIF + 70 CONTINUE + II=NPAR+NLOC+1 + 80 LGERR=COMTRE(NPAR+NLOC,NVPO(1),JARBVA,JDEBAR, + 1 MUPL2(1,IBM),KK,I0,IORD,JJ,LAST) + IF((II.GT.NPAR+NLOC).AND.LGERR) THEN + WRITE(TEXT4,'(I4)') IORD + CALL XABORT('COMGEP: ELEMENTARY CALCULATION HAS THE SAME'// + 1 ' PARAMETERS AS ELEMENTARY CALCULATION NB '//TEXT4) + ENDIF +* +* Size of the new tree. +* + NVPNEW=NVPO(1)+NPAR+NLOC+1-MIN(II,KK) + IF(NVPNEW.GT.MAXNVP) MAXNVP=NVPNEW+MAXNVP + ALLOCATE(IDEBAR(MAXNVP+1),IARBVA(MAXNVP)) + IDEBAR(:MAXNVP+1)=0 + IARBVA(:MAXNVP)=0 +* +* Update values and suppress old PARBRE. +* + CALL COMARB(NPAR+NLOC,NVPO(1),NVPNEW,JDEBAR,JARBVA, + 1 LGNE2(1,IBM),MUPL2(1,IBM),NCALAR,IDEBAR,IARBVA) + DEALLOCATE(JARBVA,JDEBAR) + ENDIF + IF(NCALAR.NE.NCAL) CALL XABORT('COMGEP: INVALID NCALAR.') + NVPO(1)=NVPNEW + NVPO(2)=MAXNVP + CALL LCMPUT(KPCPO,'NVP',2,1,NVPO) + CALL LCMPUT(KPCPO,'NCALS',1,1,NCALAR) + CALL LCMPUT(KPCPO,'DEBARB',NVPNEW+1,1,IDEBAR) + CALL LCMPUT(KPCPO,'ARBVAL',NVPNEW,1,IARBVA) + DEALLOCATE(IARBVA,IDEBAR) + IF(NCALAR.EQ.1) THEN + ALLOCATE(IORIGI(MAXCAL)) + IORIGI(:MAXCAL)=0 + ELSE + CALL LCMLEN(KPCPO,'ORIGIN',MAXOLD,ITYLCM) + IF(MAXOLD.GT.MAXCAL) CALL XABORT('COMGEP: ORIGIN OVERFLOW(1).') + ALLOCATE(IORIGI(MAXCAL)) + IORIGI(:MAXCAL)=0 + CALL LCMGET(KPCPO,'ORIGIN',IORIGI) + ENDIF + IF(NCALAR.GT.MAXCAL) CALL XABORT('COMGEP: ORIGIN OVERFLOW(2).') + IORIGI(NCALAR)=NORIG + CALL LCMPUT(KPCPO,'ORIGIN',NCALAR,1,IORIGI) + DEALLOCATE(IORIGI) + CALL LCMSIX(KPCPO,' ',2) + 90 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(LGNE2,MUPL2) + RETURN +* + 100 FORMAT(31H COMGEP: SET GLOBAL PARAMETER ',A,3H' =,1P,E12.4) + 110 FORMAT(17H COMGEP: MUPLET =,10I6:/(17X,10I6)) + 120 FORMAT(30H COMGEP: SET LOCAL PARAMETER ',A,3H' =,1P,5E12.4/(37X, + 1 5E12.4)) + END |