Initial commit from Polytechnique Montreal

1 files changed, 82 insertions, 0 deletions

diff --git a/Dragon/src/SAPSPH.f b/Dragon/src/SAPSPH.f
new file mode 100644
index 0000000..ceb9672
--- /dev/null
+++ b/Dragon/src/SAPSPH.f
@@ -0,0 +1,82 @@
+*DECK SAPSPH
+      SUBROUTINE SAPSPH(IPEDIT,NG,NMIL,ILOC,NLOC,RVALOC)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* To recover a set of sph equivalence factors and store them as local
+* variables.
+*
+*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
+* IPEDIT  pointer to the edition object (L_EDIT signature).
+* NG      number of condensed energy groups.
+* NMIL    number of mixtures in the Saphyb.
+* ILOC    position of local parameter in RVALOC.
+* NLOC    first dimension of matrix RVALOC.
+*
+*Parameters: output
+* RVALOC  local variable values in mixtures located in RVALOC(ILOC,:).
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPEDIT
+      INTEGER NG,NMIL,ILOC,NLOC
+      REAL RVALOC(NLOC,NMIL)
+*----
+*  LOCAL VARIABLES
+*----
+      PARAMETER (NSTATE=40)
+      TYPE(C_PTR) JPEDIT,KPEDIT
+      INTEGER ISTATE(NSTATE)
+      CHARACTER TEXT12*12
+      REAL, ALLOCATABLE, DIMENSION(:) :: WORK
+*----
+*  SCRATCH STORAGE ALLOCATION
+*----
+      ALLOCATE(WORK(NMIL))
+*
+      CALL LCMGTC(IPEDIT,'LAST-EDIT',12,TEXT12)
+      CALL LCMSIX(IPEDIT,TEXT12,1)
+      CALL LCMSIX(IPEDIT,'MACROLIB',1)
+      CALL LCMGET(IPEDIT,'STATE-VECTOR',ISTATE)
+      IF(ISTATE(1).NE.NG) CALL XABORT('SAPSPH: BAD VALUE OF NG.')
+      IF(ISTATE(2).NE.NMIL) CALL XABORT('SAPSPH: BAD VALUE OF NMIL.')
+*----
+*  RECOVER SPH EQUIVALENCE FACTORS.
+*----
+      JPEDIT=LCMGID(IPEDIT,'GROUP')
+      DO 30 IGR=1,NG
+      KPEDIT=LCMGIL(JPEDIT,IGR)
+      CALL LCMLEN(KPEDIT,'NSPH',ILONG,ITYLCM)
+      IF(ILONG.GT.0) THEN
+         CALL LCMGET(KPEDIT,'NSPH',WORK)
+         DO 10 IMIL=1,NMIL
+         RVALOC(ILOC+IGR-1,IMIL)=WORK(IMIL)
+   10    CONTINUE
+      ELSE
+         DO 20 IMIL=1,NMIL
+         RVALOC(ILOC+IGR-1,IMIL)=1.0
+   20    CONTINUE
+      ENDIF
+   30 CONTINUE
+      CALL LCMSIX(IPEDIT,' ',2)
+      CALL LCMSIX(IPEDIT,' ',2)
+*----
+*  SCRATCH STORAGE DEALLOCATION
+*----
+      DEALLOCATE(WORK)
+      RETURN
+      END