diff options
Diffstat (limited to 'Dragon/src/SPHSTO.f')
| -rw-r--r-- | Dragon/src/SPHSTO.f | 141 |
1 files changed, 141 insertions, 0 deletions
diff --git a/Dragon/src/SPHSTO.f b/Dragon/src/SPHSTO.f new file mode 100644 index 0000000..3b0cfb6 --- /dev/null +++ b/Dragon/src/SPHSTO.f @@ -0,0 +1,141 @@ +*DECK SPHSTO + SUBROUTINE SPHSTO(IPSAP,ICAL,IMPX,LNEW,HEQUI,HEQNAM,NMIL,NGROUP, + 1 SPH) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Store a new set of SPH factors for an elementary calculation in a +* Saphyb. +* +*Copyright: +* Copyright (C) 2011 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 (L_SAPHYB signature). +* ICAL index of the elementary calculation being considered. +* IMPX print parameter (equal to zero for no print). +* LNEW flag set to .TRUE. to allow the overwriting of the existing +* set of SPH factors named HEQUI. +* HEQUI LOCKEY name of SPH-factor set to be stored. +* HEQNAM LOCNAM name of SPH-factor set to be stored. +* NMIL number of mixtures in the elementary calculation. +* NGROUP number of energy groups in the elementary calculation. +* SPH SPH-factor set to be stored the Saphyb. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPSAP + INTEGER ICAL,IMPX,NMIL,NGROUP + REAL SPH(NMIL,NGROUP) + LOGICAL LNEW + CHARACTER HEQUI*4,HEQNAM*80 +*---- +* LOCAL VARIABLES +*---- + PARAMETER(MAXLOC=10) + INTEGER DIMSAP(50) + CHARACTER TEXT12*12,HSMG*131,LOCTYP(MAXLOC)*4,LOCNAM(MAXLOC)*80, + 1 LOCKEY(MAXLOC)*4 + INTEGER, ALLOCATABLE, DIMENSION(:) :: LOCAD + REAL, ALLOCATABLE, DIMENSION(:) :: RVALO +*---- +* RECOVER SAPHYB CHARACTERISTICS +*---- + IF(HEQUI.EQ.' ') CALL XABORT('SPHSTO: HEQUI NOT DEFINED') + CALL LCMLEN(IPSAP,'DIMSAP',ILENG,ITYLCM) + IF(ILENG.EQ.0) CALL XABORT('SPHSTO: DIMSAP NOT DEFINED') + CALL LCMGET(IPSAP,'DIMSAP',DIMSAP) + NMIL=DIMSAP(7) ! number of mixtures + NCALS=DIMSAP(19) ! number of elementary calculations in the SAPHYB + NGROUP=DIMSAP(20)! number of energy groups + IF(IMPX.GT.0) THEN + WRITE(6,'(29H SPHSTO: number of mixtures =,I5)') NMIL + WRITE(6,'(33H SPHSTO: number of calculations =,I5)') NCALS + WRITE(6,'(34H SPHSTO: number of energy groups =,I4)') NGROUP + ENDIF + IF(ICAL.GT.NCALS) CALL XABORT('SPHSTO: ICAL INDEX OVERFLOW') +*---- +* RECOVER INFORMATION FROM caldir DIRECTORY. +*---- + WRITE(TEXT12,'(4Hcalc,I8)') ICAL + CALL LCMLEN(IPSAP,TEXT12,ILENG,ITYLCM) + IF(ILENG.EQ.0) THEN + WRITE(HSMG,'(29HSPHSTO: MISSING CALCULATION '',A12,2H''.)') + 1 TEXT12 + CALL XABORT(HSMG) + ENDIF + CALL LCMSIX(IPSAP,TEXT12,1) + CALL LCMSIX(IPSAP,'info',1) + CALL LCMGET(IPSAP,'NLOC',NLOC) + IF(NLOC+1.GT.MAXLOC) CALL XABORT('SPHSTO: MAXLOC OVERFLOW') + CALL LCMGTC(IPSAP,'LOCTYP',4,NLOC,LOCTYP) + CALL LCMGTC(IPSAP,'LOCNAM',80,NLOC,LOCNAM) + CALL LCMGTC(IPSAP,'LOCKEY',4,NLOC,LOCKEY) + ALLOCATE(LOCAD(NLOC+2)) + CALL LCMGET(IPSAP,'LOCADR',LOCAD) + DO ILOC=1,NLOC + IF ((LOCTYP(ILOC).EQ.'EQUI').AND.(LOCKEY(ILOC).EQ.HEQUI)) THEN +* SET HEQUI EXISTS. + IF(LNEW) THEN + IF(IMPX.GT.0) WRITE(6,'(31H SPHSTO: OVERWRITE SPH-FACTOR S, + 1 9HET NAMED ,A)') HEQUI + JLOC=ILOC + GO TO 10 + ELSE + CALL XABORT('SPHSTO: THIS SPH FACTOR SET EXISTS: '//HEQUI) + ENDIF + ENDIF + ENDDO +* A NEW SET OF SPH FACTORS IS DEFINED IN THE SAPHYB + JLOC=NLOC+1 + NLOC=NLOC+1 + LOCTYP(NLOC)='EQUI' + LOCKEY(NLOC)=HEQUI + IF(HEQNAM.NE.' ') THEN + LOCNAM(NLOC)=HEQNAM + ELSE + LOCNAM(NLOC)=HEQUI + ENDIF + LOCAD(NLOC+1)=LOCAD(NLOC)+NGROUP + CALL LCMPUT(IPSAP,'NLOC',1,1,NLOC) + CALL LCMPTC(IPSAP,'LOCTYP',4,NLOC,LOCTYP) + CALL LCMPTC(IPSAP,'LOCNAM',80,NLOC,LOCNAM) + CALL LCMPTC(IPSAP,'LOCKEY',4,NLOC,LOCKEY) + CALL LCMPUT(IPSAP,'LOCADR',NLOC+1,1,LOCAD) + 10 CALL LCMSIX(IPSAP,' ',2) +*---- +* LOOP OVER MIXTURES. +*---- + DO IBM=1,NMIL + WRITE(TEXT12,'(4Hmili,I8)') IBM + CALL LCMLEN(IPSAP,TEXT12,ILENG,ITYLCM) + IF(ILENG.EQ.0) THEN + WRITE(HSMG,'(29HSPHSTO: MISSING MIXTURE '',A12,2H''.)') + 1 TEXT12 + CALL XABORT(HSMG) + ENDIF + CALL LCMSIX(IPSAP,TEXT12,1) + ALLOCATE(RVALO(LOCAD(NLOC+1))) + CALL LCMGET(IPSAP,'RVALOC',RVALO) + DO IGR=1,NGROUP + RVALO(LOCAD(JLOC)+IGR-1)=SPH(IBM,IGR) + ENDDO + CALL LCMPUT(IPSAP,'RVALOC',LOCAD(NLOC+1)-1,2,RVALO) + DEALLOCATE(RVALO) + CALL LCMSIX(IPSAP,' ',2) + ENDDO + DEALLOCATE(LOCAD) + CALL LCMSIX(IPSAP,' ',2) + RETURN + END |