diff options
Diffstat (limited to 'Dragon/src/SAPGEP.f')
| -rw-r--r-- | Dragon/src/SAPGEP.f | 378 |
1 files changed, 378 insertions, 0 deletions
diff --git a/Dragon/src/SAPGEP.f b/Dragon/src/SAPGEP.f new file mode 100644 index 0000000..45cbbde --- /dev/null +++ b/Dragon/src/SAPGEP.f @@ -0,0 +1,378 @@ +*DECK SAPGEP + SUBROUTINE SAPGEP(IPSAP,IPDEPL,IPLB1,IPLB2,IPEDIT,IMPX,ITIM,NORIG, + 1 NPAR,MUPLET,LGNEW,NVPNEW,NCALAR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* To recover remaining global parameters and local values. Update the +* parameter tree for a new elementary calculation. +* +*Copyright: +* Copyright (C) 2007 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 +* IPSAP pointer to the Saphyb. +* 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. +* MUPLET tuple of indices associated to each global parameter of the +* elementary calculation. +* LGNEW parameter modification flag (.TRUE. only if the I-th global +* parameter has changed in the new elementary calculation). +* +*Parameters: output +* NVPNEW number of nodes in the global parameter tree. +* NCALAR index of the new elementary calculation. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPSAP,IPDEPL,IPLB1,IPLB2,IPEDIT + INTEGER IMPX,ITIM,NORIG,NPAR,MUPLET(NPAR),NVPNEW,NCALAR + LOGICAL LGNEW(NPAR) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) IPLB3 + PARAMETER (NDIMSA=50,MAXPAR=50) + INTEGER IDATA(NDIMSA),PARMIL(MAXPAR), + 1 PARCAD(MAXPAR+1),PARPAD(MAXPAR+1),LOCADR(MAXPAR+1) + CHARACTER PARKEY(MAXPAR)*4,PARCHR(MAXPAR)*8,PARTYP(MAXPAR)*4, + 1 PARFMT(MAXPAR)*8,PARBIB(MAXPAR)*12,PARNAM(MAXPAR)*80,TEXT4*4, + 2 TEXT8*8,TEXT12*12,NAMLCM*12,NAMMY*12,HSMG*131 + LOGICAL LGERR,EMPTY,LCM,COMTRE,LAST +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IDEBAR,IARBVA,JDEBAR,JARBVA, + 1 IORIGI + REAL, ALLOCATABLE, DIMENSION(:) :: RVALO +*---- +* RECOVER INFORMATION FROM THE 'DIMSAP' PARAMETER LIST. +*---- + NVPNEW=0 + CALL LCMGET(IPSAP,'DIMSAP',IDATA) + IF(NPAR.NE.IDATA(8)) CALL XABORT('SAPGEP: WRONG VALUE OF NPAR.') + NMIL=IDATA(7) + NPCHR=IDATA(9) + NPPNT=IDATA(10) + NLOC=IDATA(11) + NPCHRL=IDATA(12) + NPPNTL=IDATA(13) + NVPO=IDATA(17) + NCALAR=IDATA(19) + NG=IDATA(20) +*---- +* RECOVER INFORMATION FROM THE 'paramdescrip' DIRECTORY. +*---- + IF(NPAR.EQ.0) GO TO 45 + CALL LCMSIX(IPSAP,'paramdescrip',1) + CALL LCMGTC(IPSAP,'PARKEY',4,NPAR,PARKEY) + CALL LCMGTC(IPSAP,'PARTYP',4,NPAR,PARTYP) + CALL LCMGTC(IPSAP,'PARFMT',8,NPAR,PARFMT) + CALL LCMGET(IPSAP,'PARCAD',PARCAD) + CALL LCMGET(IPSAP,'PARPAD',PARPAD) + IF(NPCHR.GT.0) CALL LCMGTC(IPSAP,'PARCHR',8,NPCHR,PARCHR) + IF(NPPNT.GT.0) CALL LCMGET(IPSAP,'PARMIL',PARMIL) + IF(NPPNT.GT.0) CALL LCMGTC(IPSAP,'PARBIB',12,NPPNT,PARBIB) + CALL LCMSIX(IPSAP,' ',2) +*---- +* RECOVER REMAINING GLOBAL PARAMETERS. +*---- + DO 10 IPAR=1,NPAR + IF(PARTYP(IPAR).EQ.'VALE') THEN + GO TO 10 + ELSE IF((PARTYP(IPAR).EQ.'IRRA').OR.(PARTYP(IPAR).EQ.'TIME').OR. + 1 (PARTYP(IPAR).EQ.'PUIS').OR.(PARTYP(IPAR).EQ.'FLUB').OR. + 2 (PARTYP(IPAR).EQ.'FLUX').OR.(PARTYP(IPAR).EQ.'MASL')) THEN +* +* RECOVER GLOBAL PARAMETER VALUES FROM THE DEPLETION OBJECT. + IF(.NOT.C_ASSOCIATED(IPDEPL)) CALL XABORT('SAPGEP: NO DEPLETI' + 1 //'ON OBJECT AVAILABLE AMONG THE RHS LCM OBJECTS.') + CALL LCMGET(IPDEPL,'STATE-VECTOR',IDATA) + NBURN=IDATA(3) + NBISO=IDATA(4) + NREAC=IDATA(6) + NVAR=IDATA(7) + NBMIX=IDATA(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)) CALL XABORT('SAPGEP: MICROLIB EX' + 1 //'PECTED AT RHS.') + 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',IDATA) + MAXNBI=IDATA(2) + IF(C_ASSOCIATED(IPLB2)) THEN + CALL LCMGET(IPLB2,'STATE-VECTOR',IDATA) + MAXNBI=MAX(MAXNBI,IDATA(2)) + ENDIF + CALL COMBIB(IPLB1,IPLB2,PARTYP(IPAR),IMILI,TEXT12,TEXT8,MAXNBI, + 1 VALPAR) + IF(PARTYP(IPAR).EQ.'TEMP') VALPAR=VALPAR-273.16 + ELSE + CALL XABORT('SAPGEP: '//PARTYP(IPAR)//' IS AN UNKNOWN PARAM'// + 1 'ETER TYPE.') + ENDIF + IF(IMPX.GT.0) WRITE(6,100) PARKEY(IPAR),VALPAR +* + CALL SAPPAV(IPSAP,IPAR,NPAR,'FLOTTANT',VALPAR,NITMA,TEXT12, + 1 MUPLET(IPAR),LGNEW(IPAR)) + 10 CONTINUE + IF(IMPX.GT.2) THEN + WRITE(6,110) (MUPLET(I),I=1,NPAR) + WRITE(6,'(/)') + ENDIF + DO 15 I=1,NPAR + IF(MUPLET(I).EQ.0) THEN + WRITE(HSMG,'(33HSAPGEP: UNDEFINED MUPLET ELEMENT=,I6)') I + CALL XABORT(HSMG) + ENDIF + 15 CONTINUE +*---- +* INTRODUCE VALUES INTO GLOBAL PARAMETER TREE. +*---- +** +** 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. +** NVP 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(IPSAP,'paramarbre',1) + CALL LCMLEN(IPSAP,'ARBVAL',MAXNVP,ITYLCM) + IF(MAXNVP.EQ.0) THEN + MAXNVP=100*(NPAR+1) + ALLOCATE(IDEBAR(MAXNVP+1),IARBVA(MAXNVP)) + IDEBAR(:MAXNVP+1)=0 + IARBVA(:MAXNVP)=0 + IARBVA=0 + DO 20 I=1,NPAR + IDEBAR(I)=I+1 + IARBVA(I+1)=1 + 20 CONTINUE + IDEBAR(NPAR+1)=NPAR+2 + IDEBAR(NPAR+2)=1 + NCALAR=1 + NVPNEW=NPAR+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. +* + ALLOCATE(JDEBAR(MAXNVP+1),JARBVA(MAXNVP)) + CALL LCMGET(IPSAP,'DEBARB',JDEBAR) + CALL LCMGET(IPSAP,'ARBVAL',JARBVA) + DO 30 IPAR=1,NPAR + IF(LGNEW(IPAR)) THEN + II=IPAR + GO TO 40 + ENDIF + 30 CONTINUE + II=NPAR+1 + 40 LGERR=COMTRE(NPAR,NVPO,JARBVA,JDEBAR,MUPLET,KK,I0,IORD,JJ,LAST) + IF((II.GT.NPAR).AND.LGERR) THEN + WRITE(TEXT4,'(I4)') IORD + CALL XABORT('SAPGEP: ELEMENTARY CALCULATION HAS THE SAME'// + 1 ' GLOBAL PARAMETERS AS ELEMENTARY CALCULATION NB '//TEXT4) + ENDIF +* +* Size of the new tree. +* + NVPNEW=NVPO+NPAR+1-MIN(II,KK) + IF(NVPNEW.GT.MAXNVP) MAXNVP=NVPNEW+MAXNVP + ALLOCATE(IDEBAR(MAXNVP+1),IARBVA(MAXNVP)) + IDEBAR(NVPNEW+2:MAXNVP+1)=0 + IARBVA(NVPNEW+1:MAXNVP)=0 +* +* Update values and suppress old PARBRE. +* + CALL COMARB(NPAR,NVPO,NVPNEW,JDEBAR,JARBVA,LGNEW,MUPLET,NCALAR, + 1 IDEBAR,IARBVA) + DEALLOCATE(JARBVA,JDEBAR) + ENDIF + CALL LCMPUT(IPSAP,'NCALS',1,1,NCALAR) + CALL LCMPUT(IPSAP,'DEBARB',NVPNEW+1,1,IDEBAR) + CALL LCMPUT(IPSAP,'ARBVAL',NVPNEW,1,IARBVA) + DEALLOCATE(IARBVA,IDEBAR) + IF(NCALAR.EQ.1) THEN + MAXNCA=1000 + ALLOCATE(IORIGI(MAXNCA)) + IORIGI(:MAXNCA)=0 + ELSE + CALL LCMLEN(IPSAP,'ORIGIN',MAXNCA,ITYLCM) + IF(NCALAR.GT.MAXNCA) MAXNCA=NCALAR+MAXNCA + ALLOCATE(IORIGI(MAXNCA)) + IORIGI(:MAXNCA)=0 + CALL LCMGET(IPSAP,'ORIGIN',IORIGI) + ENDIF + IORIGI(NCALAR)=NORIG + CALL LCMPUT(IPSAP,'ORIGIN',NCALAR,1,IORIGI) + DEALLOCATE(IORIGI) + CALL LCMSIX(IPSAP,' ',2) +*---- +* RECOVER INFORMATION FROM THE 'varlocdescri' DIRECTORY. +*---- + 45 IF(NLOC.EQ.0) RETURN + CALL LCMSIX(IPSAP,'varlocdescri',1) + CALL LCMGTC(IPSAP,'PARNAM',80,NPAR,PARNAM) + CALL LCMGTC(IPSAP,'PARKEY',4,NLOC,PARKEY) + CALL LCMGTC(IPSAP,'PARTYP',4,NLOC,PARTYP) + CALL LCMGTC(IPSAP,'PARFMT',8,NLOC,PARFMT) + CALL LCMGET(IPSAP,'PARCAD',PARCAD) + IF(NPCHRL.GT.0) CALL LCMGTC(IPSAP,'PARCHR',8,NPCHRL,PARCHR) + CALL LCMSIX(IPSAP,' ',2) +* + CALL LCMGTC(IPEDIT,'LAST-EDIT',12,TEXT12) +*---- +* INITIALIZE LOCADR AND ALLOCATE RVALO. +*---- + IADR=1 + LOCADR(1)=1 + DO 50 IPAR=1,NLOC + IF((PARTYP(IPAR).EQ.'EQUI').OR.(PARTYP(IPAR).EQ.'VITE')) THEN + IADR=IADR+NG + ELSE IF(PARTYP(IPAR).EQ.'COUR') THEN + IADR=IADR+2*NG + ELSE + IADR=IADR+1 + ENDIF + LOCADR(IPAR+1)=IADR + 50 CONTINUE + NVLC=LOCADR(NLOC+1)-1 + ALLOCATE(RVALO(NVLC*NMIL)) +*---- +* RECOVER LOCAL VARIABLES. +*---- + DO 70 IPAR=1,NLOC + IF((PARTYP(IPAR).EQ.'IRRA').OR.(PARTYP(IPAR).EQ.'TIME').OR. + 1 (PARTYP(IPAR).EQ.'PUIS').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 VARIABLES FROM THE DEPLETION OBJECT. + IF(.NOT.C_ASSOCIATED(IPDEPL)) CALL XABORT('SAPGEP: NO DEPLET' + 1 //'ION OBJECT AVAILABLE AMONG THE RHS LCM OBJECTS.') + CALL LCMGET(IPDEPL,'STATE-VECTOR',IDATA) + NBURN=IDATA(3) + NBISO=IDATA(4) + NREAC=IDATA(6) + NVAR=IDATA(7) + NBMIX=IDATA(8) + CALL LCMGET(IPEDIT,'STATE-VECTOR',IDATA) + NREG=IDATA(17) + CALL COMGEN(IPDEPL,IPEDIT,NREG,NMIL,ITIM,PARTYP(IPAR),NBURN, + 1 NBMIX,NBISO,NREAC,NVAR,LOCADR(IPAR),NVLC,RVALO) + ELSE IF((PARTYP(IPAR).EQ.'TEMP').OR.(PARTYP(IPAR).EQ.'CONC')) + 1 THEN +* +* RECOVER LOCAL VARIABLES 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',IDATA) + MAXNBI=IDATA(2) + CALL LCMINF(IPEDIT,NAMLCM,NAMMY,EMPTY,ILONG,LCM) + IPLB3=C_NULL_PTR + DO 60 IBM=1,NMIL + CALL COMBIB(IPEDIT,IPLB3,PARTYP(IPAR),IBM,NAMLCM,TEXT8,MAXNBI, + 1 VALPAR) + IF(PARTYP(IPAR).EQ.'TEMP') VALPAR=VALPAR-273.16 + RVALO((IBM-1)*NVLC+LOCADR(IPAR))=VALPAR + 60 CONTINUE + CALL LCMSIX(IPEDIT,' ',2) + ELSE IF(PARTYP(IPAR).EQ.'EQUI') THEN +* RECOVER A SET OF SPH EQUIVALENCE FACTORS. + CALL SAPSPH(IPEDIT,NG,NMIL,LOCADR(IPAR),NVLC,RVALO) + ELSE + CALL XABORT('SAPGEP: '//PARTYP(IPAR)//' IS AN UNKNOWN LOCAL'// + 1 ' VARIABLE TYPE.') + ENDIF + IF(IMPX.GT.1) WRITE(6,120) PARKEY(IPAR), + 1 (RVALO((IBM-1)*NVLC+LOCADR(IPAR)),IBM=1,NMIL) + 70 CONTINUE + WRITE(TEXT12,'(''calc'',I8)') NCALAR + CALL LCMSIX(IPSAP,TEXT12,1) + CALL LCMSIX(IPSAP,'info',1) + CALL LCMPUT(IPSAP,'NLOC',1,1,NLOC) + CALL LCMPTC(IPSAP,'LOCNAM',80,NLOC,PARNAM) + CALL LCMPTC(IPSAP,'LOCKEY',4,NLOC,PARKEY) + CALL LCMPTC(IPSAP,'LOCTYP',4,NLOC,PARTYP) + CALL LCMPUT(IPSAP,'LOCADR',NLOC+1,1,LOCADR) + CALL LCMSIX(IPSAP,' ',2) + DO 80 IBM=1,NMIL + WRITE(TEXT12,'(''mili'',I8)') IBM + CALL LCMSIX(IPSAP,TEXT12,1) + CALL LCMPUT(IPSAP,'RVALOC',NVLC,2,RVALO((IBM-1)*NVLC+1)) + CALL LCMSIX(IPSAP,' ',2) + 80 CONTINUE + CALL LCMSIX(IPSAP,' ',2) + DEALLOCATE(RVALO) + RETURN +* + 100 FORMAT(31H SAPGEP: SET GLOBAL PARAMETER ',A,3H' =,1P,E12.4) + 110 FORMAT(/16H SAPGEP: MUPLET=,10I6:/(16X,10I6)) + 120 FORMAT(29H SAPGEP: SET LOCAL VARIABLE ',A,3H' =,1P,5E12.4/(36X, + 1 5E12.4)) + END |