Initial commit from Polytechnique Montreal

1 files changed, 147 insertions, 0 deletions

diff --git a/Trivac/src/KININI.f b/Trivac/src/KININI.f
new file mode 100755
index 0000000..36964a5
--- /dev/null
+++ b/Trivac/src/KININI.f
@@ -0,0 +1,147 @@
+*DECK KININI
+      SUBROUTINE KININI(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Initialize the space-time kinetics parameters.
+*
+*Copyright:
+* Copyright (C) 2008 Ecole Polytechnique de Montreal.
+*
+*Author(s): D. Sekki
+*
+*Parameters: input/output
+* NENTRY  number of LCM objects or files used by the operator.
+* HENTRY  name of each LCM object or file:
+*         HENTRY(1): create type(L_KINET);
+*         HENTRY(2): read-only type(L_MACROLIB);
+*         HENTRY(3): read-only type(L_TRACK);
+*         HENTRY(4): read-only type(L_SYSTEM);
+*         HENTRY(5): read-only type(L_FLUX).
+* IENTRY  type of each LCM object or file:
+*         =1 LCM memory object; =2 XSM file; =3 sequential binary file;
+*         =4 sequential ascii file.
+* JENTRY  access of each LCM object or file:
+*         =0 the LCM object or file is created;
+*         =1 the LCM object or file is open for modifications;
+*         =2 the LCM object or file is open in read-only mode.
+* KENTRY  LCM object address or file unit number.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY)
+      CHARACTER HENTRY(NENTRY)*12
+      TYPE(C_PTR) KENTRY(NENTRY)
+*----
+*  LOCAL VARIABLES
+*----
+      PARAMETER(NSTATE=40)
+      INTEGER ISTATE(NSTATE)
+      CHARACTER TEXT12*12,HSIGN*12,CMODUL*12,HSMG*131
+*----
+*  PARAMETER VALIDATION
+*----
+      IF(NENTRY.NE.5)CALL XABORT('@KININI: INVALID NUMBER OF MODULE PA'
+     1 //'RAMETERS.')
+      DO IEN=2,NENTRY
+       IF((IENTRY(IEN).NE.1).AND.(IENTRY(IEN).NE.2))
+     1   CALL XABORT('@KININI: LCM OBJECTS EXPECTED AT RHS')
+       IF(JENTRY(IEN).NE.2)CALL XABORT('@KININI: LCM OBJEC'
+     1  //'TS IN READ-ONLY MODE EXPECTED AT RHS.')
+      ENDDO
+*     L_KINET
+      IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2))
+     1 CALL XABORT('@KININI: LCM OBJECT EXPECTED AT LHS.')
+      IF(JENTRY(1).NE.0)CALL XABORT('@KININI: L_KINET IN'
+     1 //' CREATE MODE EXPECTED.')
+      HSIGN='L_KINET'
+      CALL LCMPTC(KENTRY(1),'SIGNATURE',12,HSIGN)
+*     L_MACROLIB
+      CALL LCMGTC(KENTRY(2),'SIGNATURE',12,HSIGN)
+      IF(HSIGN.NE.'L_MACROLIB')THEN
+        TEXT12=HENTRY(2)
+        CALL XABORT('@KININI: SIGNATURE OF '//TEXT12//' IS '
+     1  //HSIGN//'. L_MACROLIB EXPECTED.')
+      ENDIF
+*     L_TRACK
+      CALL LCMGTC(KENTRY(3),'SIGNATURE',12,HSIGN)
+      IF(HSIGN.NE.'L_TRACK')THEN
+        TEXT12=HENTRY(3)
+        CALL XABORT('@KININI: SIGNATURE OF '//TEXT12//' IS '
+     1  //HSIGN//'. L_TRACK EXPECTED.')
+      ENDIF
+*     L_SYSTEM
+      CALL LCMGTC(KENTRY(4),'SIGNATURE',12,HSIGN)
+      IF(HSIGN.NE.'L_SYSTEM')THEN
+        TEXT12=HENTRY(4)
+        CALL XABORT('@KININI: SIGNATURE OF '//TEXT12//' IS '
+     1  //HSIGN//'. L_SYSTEM EXPECTED.')
+      ENDIF
+      CALL LCMGTC(KENTRY(4),'LINK.MACRO',12,TEXT12)
+      IF(HENTRY(2).NE.TEXT12) THEN
+        WRITE(HSMG,'(40H@KININI: INVALID MACROLIB OBJECT NAME ='',A12,
+     1  18H'', EXPECTED NAME='',A12,2H''.)') HENTRY(2),TEXT12
+        CALL XABORT(HSMG)
+      ENDIF
+      CALL LCMGTC(KENTRY(4),'LINK.TRACK',12,TEXT12)
+      IF(HENTRY(3).NE.TEXT12) THEN
+        WRITE(HSMG,'(40H@KININI: INVALID TRACKING OBJECT NAME ='',A12,
+     1  18H'', EXPECTED NAME='',A12,2H''.)') HENTRY(3),TEXT12
+        CALL XABORT(HSMG)
+      ENDIF
+*     L_FLUX
+      CALL LCMGTC(KENTRY(5),'SIGNATURE',12,HSIGN)
+      IF(HSIGN.NE.'L_FLUX')THEN
+        TEXT12=HENTRY(5)
+        CALL XABORT('@KININI: SIGNATURE OF '//TEXT12//' IS '
+     1  //HSIGN//'. L_FLUX EXPECTED.')
+      ENDIF
+*----
+*  OBJECTS VALIDATION
+*----
+      ISTATE(:NSTATE)=0
+      CALL LCMGET(KENTRY(5),'STATE-VECTOR',ISTATE)
+      NGR=ISTATE(1)
+      NUN=ISTATE(2)
+      ISTATE(:NSTATE)=0
+      CALL LCMGET(KENTRY(2),'STATE-VECTOR',ISTATE)
+      IF(ISTATE(1).NE.NGR)CALL XABORT('@KININI: INVALID NU'
+     1 //'MBER OF ENERGY GROUPS IN L_MACROLIB OR IN L_FLUX.')
+      NBM=ISTATE(2)
+      NBFIS=ISTATE(4)
+      NDG=ISTATE(7)
+      ISTATE(:NSTATE)=0
+      CALL LCMGET(KENTRY(3),'STATE-VECTOR',ISTATE)
+      IF(ISTATE(2).NE.NUN)CALL XABORT('@KININI: INVALID TOTAL'
+     1 //' NUMBER OF UNKNOWNS IN L_FLUX OR IN L_TRACK.')
+      IF(ISTATE(4).GT.NBM) THEN
+         WRITE(HSMG,'(46H@KININI: THE NUMBER OF MIXTURES IN THE TRACKIN,
+     1   3HG (,I5,50H) IS GREATER THAN THE NUMBER OF MIXTURES IN THE MA,
+     2   8HCROLIB (,I5,2H).)') ISTATE(4),NBM
+         CALL XABORT(HSMG)
+      ENDIF
+      ITYPE=ISTATE(6)
+      CALL LCMGTC(KENTRY(3),'TRACK-TYPE',12,CMODUL)
+*
+      IF(CMODUL.EQ.'BIVAC')THEN
+        IF((ITYPE.NE.1).AND.(ITYPE.NE.2).AND.(ITYPE.NE.3).AND.
+     1     (ITYPE.NE.4).AND.(ITYPE.NE.5).AND.(ITYPE.NE.6).AND.
+     2     (ITYPE.NE.8))CALL XABORT('@KININI: TYPE OF GEOMETR'
+     3     //'Y NOT COMPATIBLE WITH BIVAC TRACKING-TYPE.')
+      ELSEIF(CMODUL.EQ.'TRIVAC')THEN
+        IF((ITYPE.NE.1).AND.(ITYPE.NE.2).AND.(ITYPE.NE.3).AND.
+     1     (ITYPE.NE.5).AND.(ITYPE.NE.6).AND.(ITYPE.NE.7).AND.
+     2     (ITYPE.NE.8).AND.(ITYPE.NE.9))CALL XABORT('@KININI'
+     3     //': TYPE OF GEOMETRY NOT COMPATIBLE WITH TRIVAC T'
+     4     //'RACKING-TYPE.')
+      ENDIF
+      NEL=ISTATE(1)
+      CALL LCMPTC(KENTRY(1),'TRACK-TYPE',12,CMODUL)
+      CALL KINRD1(NENTRY,KENTRY,CMODUL,NGR,NBM,NBFIS,NEL,NUN,NDG)
+      RETURN
+      END