*DECK THM
      SUBROUTINE THM(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY)
*
*-----------------------------------------------------------------------
*
*Purpose:
* simplified thermal-hydraulics module.
*
*Copyright:
* Copyright (C) 2013 Ecole Polytechnique de Montreal.
*
*Author(s): A. Hebert, P. Gallet, V. Salino
*
*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 or modification type(L_THM);
*         HENTRY(2): modification type(L_MAP);
* 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)
      TYPE(C_PTR)  KENTRY(NENTRY)
      CHARACTER    HENTRY(NENTRY)*12
*----
*  LOCAL VARIABLES
*----
      PARAMETER(NSTATE=40,IOUT=6,PI=3.141592654)
      PARAMETER(IMAXO=100,JMAXO=100,KMAXO=100,NMAXO=20)
      CHARACTER TEXT*40,TEXT12*12,HSIGN*12,PNAME*12,TXTDIR*12,
     > UCONDF*12,UCONDC*12
      INTEGER ISTATE(NSTATE),TPREV,TIMEIT,ITIME
      REAL STATE(NSTATE),DTIME,KHGAP,KHCONV,WTEFF
      REAL HX(IMAXO),HY(JMAXO),HZ(KMAXO),VVAL(KMAXO),TCVAL(KMAXO),
     > PVAL(KMAXO),HVAL(KMAXO),DVAL(KMAXO),TVAL(KMAXO*NMAXO),
     > DLVAL(KMAXO),PIN0,TIN0,PINLET,POULET
      DOUBLE PRECISION DFLOT
      TYPE(C_PTR) IPTHM,IPMAP,JPMAP,KPMAP,JPTHM,KPTHM,MPTHM
      INTEGER, ALLOCATABLE, DIMENSION(:) :: NUM
      REAL, ALLOCATABLE, DIMENSION(:) :: XX,YY,ZZ,BURN,PW,VAL
      REAL, ALLOCATABLE, DIMENSION(:) :: XBURN,POW,TCOMB,TCENT,DCOOL,
     1 TCOOL,TSURF,VCOOL,PCOOL,HCOOL,TCODI,DLIQU,VELOI,DENSI,PRESI,
     2 ENTHI,TEMPI,CENTI,DLIQI,VELOF,DENSF,PRESF,ENTHF,TEMPF,CENTF,
     3 DLIQF
      REAL, ALLOCATABLE, DIMENSION(:) :: KCONDF, KCONDC
*----
*  PARAMETER VALIDATION
*----
      IF(NENTRY.NE.2)CALL XABORT('@THM: 2 PARAMETERS EXPECTED.')
      IPTHM=KENTRY(1)
      IPMAP=KENTRY(2)
      IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2))CALL XABORT('@THM:'
     1 //' LCM OBJECT EXPECTED AT FIRST LHS.')
      IF((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2))CALL XABORT('@THM:'
     1 //' LCM OBJECT EXPECTED AT SECOND LHS.')
      CALL LCMGTC(IPMAP,'SIGNATURE',12,1,HSIGN)
      IF(HSIGN.NE.'L_MAP')THEN
        TEXT=HENTRY(2)
        CALL XABORT('@THM: SIGNATURE OF '//TEXT//' IS '//HSIGN//
     1  '. L_MAP EXPECTED.')
      ENDIF
*----
*  RECOVER L_MAP STATE-VECTOR
*----
      CALL LCMGET(IPMAP,'STATE-VECTOR',ISTATE)
      NB=ISTATE(1)
      NCH=ISTATE(2)
      NPARM=ISTATE(8)
*----
*  READ DATA
*----
      IMPX=1
      ITIME=0
      DTIME=0.0
      FPUISS=0.974
      CFLUX=2.0E+6
      SPEED=0.0
      TINLET=0.
      POULET=0.0
      FRACPU=0.0
      POROS=0.05
      ICONDF=0
      ICONDC=0
      IHGAP=0
      IHCONV=0
      IFRCDI=0
      ISUBM=0
      RC=0.0
      RIG=0.0
      RGG=0.0
      RTG=0.0
      SASS=0.0
      NFU=0
      NTG=0
      MAXIT1=50
      MAXIT2=50
      MAXIT3=50
      ERMAXT=1.0
      ERMAXC=1.0E-3
      NFD=5
      NDTOT=8
      TIMEIT=0
      RELAX=1.0
      RTIME=0.0
      WTEFF=5.0/9.0 ! Rowlands weighting factor
      IF(JENTRY(1).EQ.1) THEN
        CALL LCMGET(IPTHM,'STATE-VECTOR',ISTATE)
        NFU=ISTATE(1)
        NTG=ISTATE(2)
        MAXIT1=ISTATE(3)
        MAXIT2=ISTATE(4)
        MAXIT3=ISTATE(5)
        NFD=ISTATE(6)
        NDTOT=ISTATE(7)
        ITIME=ISTATE(8)
        TIMEIT=ISTATE(9)
        IHGAP=ISTATE(10)
        IHCONV=ISTATE(11)
        ICONDF=ISTATE(12)
        ICONDC=ISTATE(13)
        IFRCDI=ISTATE(14)
        ISUBM=ISTATE(15)
        IF(ICONDF.EQ.1) NCONDF=ISTATE(16)
        IF(ICONDC.EQ.1) NCONDC=ISTATE(17)
        CALL LCMGET(IPTHM,'REAL-PARAM',STATE)
        DTIME=STATE(1)
        FPUISS=STATE(2)
        CFLUX=STATE(3)
        SPEED=STATE(4)
        POULET=STATE(5)
        TINLET=STATE(6)
        FRACPU=STATE(7)
        POROS=STATE(8)
        RC=STATE(9)
        RIG=STATE(10)
        RGG=STATE(11)
        RTG=STATE(12)
        SASS=STATE(13)
        ERMAXT=STATE(14)
        ERMAXC=STATE(15)
        RELAX=STATE(16)
        RTIME=STATE(17)
        IF(IHGAP.EQ.1) KHGAP=STATE(18)
        IF(IHCONV.EQ.1) KHCONV=STATE(19)
        WTEFF=STATE(20)
*----
*  RECOVER CONDUCTIVITY INFORMATION ON LCM OBJECT THM
*----
        IF(ICONDF.EQ.1) THEN
          ALLOCATE(KCONDF(NCONDF+3))
          CALL LCMGET(IPTHM,'KCONDF',KCONDF)
          CALL LCMGTC(IPTHM,'UCONDF',12,1,UCONDF)
        ENDIF
        IF(ICONDC.EQ.1) THEN
          ALLOCATE(KCONDC(NCONDC+1))
          CALL LCMGET(IPTHM,'KCONDC',KCONDC)
          CALL LCMGTC(IPTHM,'UCONDC',12,1,UCONDC)
        ENDIF
      ENDIF
*----
*  READ INPUT DATA
*----
   10 CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
      IF(ITYP.EQ.10)GO TO 20
      IF(ITYP.NE.3)CALL XABORT('@THM: CHARACTER DATA EXPECTED.')
      IF(TEXT.EQ.'EDIT') THEN
*       READ PRINTING INDEX
        CALL REDGET(ITYP,IMPX,FLOT,TEXT,DFLOT)
        IF(ITYP.NE.1)CALL XABORT('@THM: INTEGER FOR EDIT EXPECTED.')
      ELSE IF(TEXT.EQ.'TIME') THEN
*       Calculation type : =0 for static, =1 for transient
        CALL REDGET(ITYP,ITIME,FLOT,TEXT,DFLOT)
        IF(ITYP.NE.1)CALL XABORT('@THM: INTEGER FOR ITIME EXPECTED.')
*       Time step for transient calculation : =0.0 for static (default
*       value)
        CALL REDGET(ITYP,NITMA,DTIME,TEXT,DFLOT)
        IF(ITYP.NE.2)CALL XABORT('@THM: REAL FOR DTIME EXPECTED.')
*       iteration number in case of transient calculation
        CALL REDGET(ITYP,TIMEIT,FLOT,TEXT,DFLOT)
        IF(ITYP.NE.1)CALL XABORT('@THM: INTEGER FOR TIMEIT EXPECTED.')
*       Current time of the simulation
        CALL REDGET(ITYP,NITMA,RTIME,TEXT,DFLOT)
        IF(ITYP.NE.2)CALL XABORT('@THM: REAL FOR RTIME EXPECTED.')
      ELSE IF(TEXT.EQ.'FPUISS') THEN
*       Coolant power factor
        CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
        IF(ITYP.EQ.2) THEN
           FPUISS=FLOT
        ELSE
           CALL XABORT('@THM: REAL FOR FPUISS EXPECTED.')
        ENDIF
      ELSE IF(TEXT.EQ.'CRITFL') THEN
*       Critical heat flux (W/m^2)
        CALL REDGET(ITYP,NITMA,CFLUX,TEXT,DFLOT)
        IF(ITYP.NE.2)CALL XABORT('@THM: REAL FOR CFLUX EXPECTED.')
      ELSE IF(TEXT.EQ.'CWSECT') THEN
*       Core coolant section (m^2)
        CALL REDGET(ITYP,NITMA,CWSECT,TEXT,DFLOT)
        IF(ITYP.NE.2)CALL XABORT('@THM: REAL FOR CWSECT EXPECTED.')
*       Coolant flow (m^3/h)
        CALL REDGET(ITYP,NITMA,FLOW,TEXT,DFLOT)
        IF(ITYP.NE.2)CALL XABORT('@THM: REAL FOR FLOW EXPECTED.')
        SPEED=FLOW/(3600.0*CWSECT)
      ELSE IF(TEXT.EQ.'SPEED') THEN
*       Coolant velocity (m/s)
        CALL REDGET(ITYP,NITMA,SPEED,TEXT,DFLOT)
        IF(ITYP.NE.2)CALL XABORT('@THM: REAL FOR SPEED EXPECTED.')
      ELSE IF(TEXT.EQ.'INLET') THEN
*       The POULET and TINLET informations are used to compute initial
*       enthalpy and water density.
*       Outlet pressure (Pa)
        CALL REDGET(ITYP,NITMA,POULET,TEXT,DFLOT)
        IF(ITYP.NE.2)CALL XABORT('@THM: REAL FOR POULET EXPECTED.')
*       Inlet temperature (K)
        CALL REDGET(ITYP,NITMA,TINLET,TEXT,DFLOT)
        IF(ITYP.NE.2)CALL XABORT('@THM: REAL FOR TINLET EXPECTED.')
      ELSE IF(TEXT.EQ.'PUFR') THEN
        ICONDF=0
*       Plutonium mass enrichment
        CALL REDGET(ITYP,NITMA,FRACPU,TEXT,DFLOT)
        IF(ITYP.NE.2)CALL XABORT('@THM: REAL FOR PUFR EXPECTED.')
      ELSE IF(TEXT.EQ.'POROS') THEN
        ICONDF=0
*       Oxyde porosity
        CALL REDGET(ITYP,NITMA,POROS,TEXT,DFLOT)
        IF(ITYP.NE.2)CALL XABORT('@THM: REAL FOR POROS EXPECTED.')
      ELSE IF(TEXT.EQ.'CONDF') THEN
        IF(ICONDF.EQ.1)DEALLOCATE(KCONDF)
        ICONDF=1
*       Fuel conductivity expressed as a function of fuel temperature
*       (function = polynomial + inverse term)
        CALL REDGET(ITYP,NCONDF,FLOT,TEXT,DFLOT)
        IF(ITYP.NE.1)CALL XABORT('@THM: INTEGER FOR CONDF EXPECTED.')
        IF(NCONDF.LT.0)CALL XABORT('@THM: NCONDF MUST BE LARGER OR '
     >                  //'EQUAL TO 0.')
        ALLOCATE(KCONDF(NCONDF+3))
        DO I=1,NCONDF+1
          CALL REDGET(ITYP,NITMA,KCONDF(I),TEXT,DFLOT)
          IF(ITYP.NE.2)CALL XABORT('@THM: REAL FOR KCONDF EXPECTED.')
        ENDDO
        CALL REDGET(ITYP,NITMA,FLOT,TEXT12,DFLOT)
        IF(ITYP.NE.3)CALL XABORT('@THM: CHARACTER DATA EXPECTED (INV, '
     >     //'CELSIUS OR KELVIN) IN CONDF STATEMENT.')
        IF(TEXT12.EQ.'INV') THEN
          CALL REDGET(ITYP,NITMA,KCONDF(NCONDF+2),TEXT,DFLOT)
          IF(ITYP.NE.2)CALL XABORT('@THM: REAL FOR INV EXPECTED.')
          CALL REDGET(ITYP,NITMA,KCONDF(NCONDF+3),TEXT,DFLOT)
          IF(ITYP.NE.2)CALL XABORT('@THM: REAL FOR REF EXPECTED.')
          CALL REDGET(ITYP,NITMA,FLOT,TEXT12,DFLOT)
        ELSE
          KCONDF(NCONDF+2)=0.0 ! Coefficient for the inverse term
          KCONDF(NCONDF+3)=-273.15 ! Reference for the inverse term
        ENDIF
        IF((TEXT12.NE.'CELSIUS').AND.(TEXT12.NE.'KELVIN')) THEN
          CALL XABORT('@THM: UNIT KEYWORD EXPECTED (CELSIUS OR '
     >                //'KELVIN) IN CONDF STATEMENT.')
        ENDIF
        UCONDF=TEXT12
      ELSE IF(TEXT.EQ.'CONDC') THEN
        IF(ICONDC.EQ.1)DEALLOCATE(KCONDC)
        ICONDC=1
*       Clad conductivity expressed as a polynomial of clad temperature
        CALL REDGET(ITYP,NCONDC,FLOT,TEXT,DFLOT)
        IF(ITYP.NE.1)CALL XABORT('@THM: INTEGER FOR CONDC EXPECTED.')
        IF(NCONDC.LT.0)CALL XABORT('@THM: NCONDC MUST BE LARGER OR '
     >                  //'EQUAL TO 0.')
        ALLOCATE(KCONDC(NCONDC+1))
        DO I=1,NCONDC+1
          CALL REDGET(ITYP,NITMA,KCONDC(I),TEXT,DFLOT)
          IF(ITYP.NE.2)CALL XABORT('@THM: REAL FOR KCONDC EXPECTED.')
        ENDDO
        CALL REDGET(ITYP,NITMA,FLOT,UCONDC,DFLOT)
        IF((ITYP.NE.3).OR.((UCONDC.NE.'CELSIUS').AND.
     >                     (UCONDC.NE.'KELVIN'))) THEN
          CALL XABORT('@THM: UNIT KEYWORD EXPECTED (CELSIUS OR '
     >                //'KELVIN) IN CONDC STATEMENT.')
        ENDIF
      ELSE IF(TEXT.EQ.'HGAP') THEN
        IHGAP=1
*       Fixed, user-chosen value of the HGAP (heat exchange coefficient
*       of the gap) (W/m^2/K)
        CALL REDGET(ITYP,NITMA,KHGAP,TEXT,DFLOT)
        IF(ITYP.NE.2)CALL XABORT('@THM: REAL FOR HGAP EXPECTED.')
      ELSE IF(TEXT.EQ.'HCONV') THEN
        IHCONV=1
*       Fixed, user-chosen value of the HCONV (heat transfer coefficient
*       between clad and fluid) (W/m^2/K)
        CALL REDGET(ITYP,NITMA,KHCONV,TEXT,DFLOT)
        IF(ITYP.NE.2)CALL XABORT('@THM: REAL FOR HCONV EXPECTED.')
      ELSE IF(TEXT.EQ.'TEFF') THEN
*       Surface temperature's weighting factor in effective fuel
*       temperature
        CALL REDGET(ITYP,NITMA,WTEFF,TEXT,DFLOT)
        IF(ITYP.NE.2)CALL XABORT('@THM: REAL FOR TEFF EXPECTED.')
      ELSE IF(TEXT.EQ.'FORCEAVE') THEN
*       Force the use of the average value approximation for fuel
*       conductivity
        IFRCDI=1
      ELSE IF(TEXT.EQ.'BOWR') THEN
*       Jens-Lottes correlation and Bowring's model
        ISUBM=0
      ELSE IF(TEXT.EQ.'SAHA') THEN
*       Saha-Zuber correlation
        ISUBM=1
      ELSE IF(TEXT.EQ.'RADIUS') THEN
*       Fuel pellet radius (m)
        CALL REDGET(ITYP,NITMA,RC,TEXT,DFLOT)
        IF(ITYP.NE.2)CALL XABORT('@THM: REAL FOR RC EXPECTED.')
*       Internal clad rod radius (m)
        CALL REDGET(ITYP,NITMA,RIG,TEXT,DFLOT)
        IF(ITYP.NE.2)CALL XABORT('@THM: REAL FOR RIG EXPECTED.')
*       External clad rod radius (m)
        CALL REDGET(ITYP,NITMA,RGG,TEXT,DFLOT)
        IF(ITYP.NE.2)CALL XABORT('@THM: REAL FOR RGG EXPECTED.')
*       Guide tube radius (m)
        CALL REDGET(ITYP,NITMA,RTG,TEXT,DFLOT)
        IF(ITYP.NE.2)CALL XABORT('@THM: REAL FOR RTG EXPECTED.')
      ELSE IF(TEXT.EQ.'ASSMB') THEN
*       Assembly surface (m^2)
        CALL REDGET(ITYP,NITMA,SASS,TEXT,DFLOT)
        IF(ITYP.NE.2)CALL XABORT('@THM: REAL FOR SASS EXPECTED.')
*       Number of active fuel rods
        CALL REDGET(ITYP,NFU,FLOT,TEXT,DFLOT)
        IF(ITYP.NE.1)CALL XABORT('@THM: INTEGER FOR NFU EXPECTED.')
*       Number of guide tubes
        CALL REDGET(ITYP,NTG,FLOT,TEXT,DFLOT)
        IF(ITYP.NE.1)CALL XABORT('@THM: INTEGER FOR NTG EXPECTED.')
      ELSE IF(TEXT.EQ.'CONV') THEN
*       Number of conduction iterations
        CALL REDGET(ITYP,MAXIT1,FLOT,TEXT,DFLOT)
        IF(ITYP.NE.1)CALL XABORT('@THM: INTEGER FOR MAXIT1 EXPECTED.')
*       Number of center-pellet iterations
        CALL REDGET(ITYP,MAXIT2,FLOT,TEXT,DFLOT)
        IF(ITYP.NE.1)CALL XABORT('@THM: INTEGER FOR MAXIT2 EXPECTED.')
*       Number of flow iterations
        CALL REDGET(ITYP,MAXIT3,FLOT,TEXT,DFLOT)
        IF(ITYP.NE.1)CALL XABORT('@THM: INTEGER FOR MAXIT3 EXPECTED.')
*       Temperature maximum error (K)
        CALL REDGET(ITYP,NITMA,ERMAXT,TEXT,DFLOT)
        IF(ITYP.NE.2)CALL XABORT('@THM: REAL FOR ERMAXT EXPECTED.')
*       maximum relative error for the calculation of the properties
*       in the coolant (pressure, enthalpy, density, velocity,...)
        CALL REDGET(ITYP,NITMA,ERMAXC,TEXT,DFLOT)
        IF(ITYP.NE.2)CALL XABORT('@THM: REAL FOR ERMAXC EXPECTED.')
      ELSE IF(TEXT.EQ.'RODMESH') THEN
*       Number of discretisation points in fuel
        CALL REDGET(ITYP,NFD,FLOT,TEXT,DFLOT)
        IF(ITYP.NE.1)CALL XABORT('@THM: INTEGER FOR NFD EXPECTED.')
*       Number of discretisation points in fuel rod (fuel+cladding)
        CALL REDGET(ITYP,NDTOT,FLOT,TEXT,DFLOT)
        IF(ITYP.NE.1)CALL XABORT('@THM: INTEGER FOR NDTOT EXPECTED.')
      ELSE IF(TEXT.EQ.'RELAX') THEN
*       Relaxation parameter
        CALL REDGET(ITYP,NITMA,RELAX,TEXT,DFLOT)
        IF(ITYP.NE.2)CALL XABORT('@THM: REAL FOR RELAX EXPECTED.')
      ELSE IF(TEXT.EQ.'SET-PARAM') THEN
*       Reset a global parameter
        CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
        IF(ITYP.NE.3)CALL XABORT('@THM: CHARACTER NAME EXPECTED.')
        CALL REDGET(ITYP,NITMA,VALUE,TEXT,DFLOT)
        IF(ITYP.NE.2)CALL XABORT('@THM: REAL FOR VALUE EXPECTED.')
        JPMAP=LCMGID(IPMAP,'PARAM')
        DO 15 IPAR=1,NPARM
        KPMAP=LCMGIL(JPMAP,IPAR)
        CALL LCMGTC(KPMAP,'P-NAME',12,1,PNAME)
        CALL LCMGET(KPMAP,'P-TYPE',ITYPE)
        IF(ITYPE.EQ.1) THEN
          IF(PNAME.EQ.TEXT) THEN
            CALL LCMPUT(KPMAP,'P-VALUE',1,2,VALUE)
            IF(IMPX.GT.0) WRITE(6,400) PNAME,VALUE
            GO TO 10
          ELSE
            GO TO 15
          ENDIF
        ELSE IF(ITYPE.EQ.2) THEN
          CALL XABORT('@THM: CANNOT RESET LOCAL PARAMETER: '//TEXT)
        ENDIF
   15   CONTINUE
        CALL XABORT('@THM: GLOBAL PARAMETER NAME NOT FOUND: '//TEXT)
      ELSE IF(TEXT.EQ.';') THEN
        GO TO 20
      ELSE
        CALL XABORT('@THM: INVALID KEYWORD: '//TEXT//'.')
      ENDIF
      GO TO 10
*----
*  TEST DATA INPUT
*----
   20 IF(SPEED.EQ.0.0) CALL XABORT('@THM: ZERO COOLANT SPEED.')
      IF(TINLET.EQ.0.0) CALL XABORT('@THM: ZERO INLET TEMPERATURE.')
      IF(POULET.EQ.0.0) CALL XABORT('@THM: ZERO OUTLET PRESSURE.')
      IF(RC.EQ.0.0) CALL XABORT('@THM: ZERO FUEL PELLET RADIUS.')
      IF(RIG.EQ.0.0) CALL XABORT('@THM: ZERO INTERNAL CLAD ROD RADIUS.')
      IF(RGG.EQ.0.0) CALL XABORT('@THM: ZERO EXTERNAL CLAD ROD RADIUS.')
      IF(SASS.EQ.0.0) CALL XABORT('@THM: ZERO ASSEMBLY SURFACE.')
      IF(NFU.EQ.0) CALL XABORT('@THM: NO FUEL RODS.')
      IF(NDTOT.GT.NMAXO) CALL XABORT('@THM: NFD OVERFLOW, TOO MANY FUE'
     > //'L DOMAINS')
      IF(NDTOT.LT.8) CALL XABORT('@THM: NDTOT MUST AT LEAST BE EQUAL T'
     > //'O 8')
      IF(NFD.LT.4) CALL XABORT('@THM: NFD MUST AT LEAST BE EQUAL TO 4')
      IF(NFD.GE.NDTOT) CALL XABORT('@THM: NFD MUST BE LOWER THAN NDTO'
     > //'T.')
      IF((RELAX.LE.0.0).OR.(RELAX.GT.1.0)) CALL XABORT('@THM: RELAX '
     >  //'PARAMETER EXPECTED BETWEEN 0<RELAX<=1.')
      IF((WTEFF.LT.0.0).OR.(WTEFF.GT.1.0)) CALL XABORT('@THM: WTEFF '
     >  //'PARAMETER EXPECTED BETWEEN 0<=WTEFF<=1.')
*----
*  RECOVER GEOMAP STATE-VECTOR
*---- 
      JPMAP=LCMGID(IPMAP,'GEOMAP')
      CALL LCMGET(JPMAP,'STATE-VECTOR',ISTATE)
      IF(ISTATE(1).NE.7) CALL XABORT('@THM:'
     1 //' 3-D CARTESIAN GEOMETRY EXPECTED.')
      NX=ISTATE(3)
      NY=ISTATE(4)
      NZ=ISTATE(5)
      NEL=ISTATE(6)
      IF(NX.GT.IMAXO) CALL XABORT('@THM: NX OVERFLOW.')
      IF(NY.GT.JMAXO) CALL XABORT('@THM: NY OVERFLOW.')
      IF(NZ.GT.KMAXO) CALL XABORT('@THM: NZ OVERFLOW.')
*----
*  COMPUTE HYDRAULICS CONSTANTS
*  RC:      fuel pellet radius in m
*  RTG:     guide tube radius in m
*  ACOOL:   coolant cross section per assembly in m^2
*  RAPCOOL: assembly over coolant volumic ratio
*  RAPFUEL: assembly over fuel volumic ratio
*  FCOOL:   power density fraction in coolant.
*  FFUEL:   power density fraction in fuel.
*  PCH:     heating perimeter in m
*  PM:      perimeter in contact with flow in m
*  HD:      hydraulic diameter of one assembly in m
*  SPEED:   inlet flow velocity in m/s
*----
      ACOOL=SASS-NFU*PI*RGG*RGG-NTG*PI*RTG*RTG
      RAPCOOL=SASS/ACOOL
      RAPFUEL=SASS/(NFU*PI*RC*RC)
      FCOOL=(1.0-FPUISS)*RAPCOOL
      FFUEL=FPUISS*RAPFUEL
      PCH=NFU*2.0*PI*RGG
      PM=PCH+NTG*2.0*PI*RTG
      HD=4.0*ACOOL/PM
*----
*  RECOVER REACTOR MESH IN METER
*----
      ALLOCATE(XX(NX+1),YY(NY+1),ZZ(NZ+1))
      CALL LCMGET(JPMAP,'MESHX',XX)
      CALL LCMGET(JPMAP,'MESHY',YY)
      CALL LCMGET(JPMAP,'MESHZ',ZZ)
      DO 30 I=1,NX
   30 HX(I)=(XX(I+1)-XX(I))/100.0
      DO 40 I=1,NY
   40 HY(I)=(YY(I+1)-YY(I))/100.0
      DO 50 I=1,NZ
   50 HZ(I)=(ZZ(I+1)-ZZ(I))/100.0
      DEALLOCATE(ZZ,YY,XX)
*----
*  RECOVER LOCAL PARAMETER INFORMATION FROM L_MAP OBJECT
*----
      ALLOCATE(NUM(NEL),BURN(NCH*NB),PW(NCH*NB))
      CALL LCMGET(IPMAP,'BMIX',NUM)
      CALL LCMGET(IPMAP,'BURN-INST',BURN)
      CALL LCMGET(IPMAP,'BUND-PW',PW)
      IF(IMPX.GT.2) THEN
        PTOT=0.0
        DO I=1,NCH*NB
          PTOT=PTOT+PW(I)
        ENDDO
        WRITE(6,*) 'THM: total power=',PTOT*1.0E3,' W'
      ENDIF
*----
*  REBUILD LOCAL PARAMETER INFORMATION FOR THM:
*----
      IC=NX
      JC=NY
      KC=NZ
      ALLOCATE(XBURN(IC*JC*KC),POW(IC*JC*KC))
      CALL XDRSET(XBURN,IC*JC*KC,0.0)
      CALL XDRSET(POW,IC*JC*KC,0.0)
      ICH=0
      DO 70 IY=1,NY
      DO 70 IX=1,NX
      IEL=(IY-1)*NX+IX
      DO 55 IZ=1,NZ
      IF(NUM((IZ-1)*NX*NY+IEL).NE.0) GO TO 56
   55 CONTINUE
      GO TO 70
   56 ICH=ICH+1
      IB=0
      DO 60 IZ=1,NZ
      IF(NUM((IZ-1)*NX*NY+IEL).EQ.0) GO TO 60
      IB=IB+1
      IMA=(IB-1)*NCH+ICH
      ITH=(IZ-1)*IC*JC+(IY-1)*IC+IX
      XBURN(ITH)=BURN(IMA)
      POW(ITH)=PW(IMA)*1.0E3
   60 CONTINUE
      IF(IB.NE.NB) CALL XABORT('@THM: INVALID NUMBER OF BUNDLES.')
   70 CONTINUE
      IF(ICH.NE.NCH) CALL XABORT('@THM: INVALID NUMBER OF CHANNELS.')
      DEALLOCATE(PW,BURN)
*----
*  RECOVER AVERAGE FUEL TEMPERATURE FIELD FROM THM OBJECT
*----
      ALLOCATE(TCOMB(IC*JC*KC))
      CALL XDRSET(TCOMB,IC*JC*KC,0.0)
      JPMAP=LCMGID(IPMAP,'PARAM')
      DO 150 IPAR=1,NPARM
      KPMAP=LCMGIL(JPMAP,IPAR)
      CALL LCMGTC(KPMAP,'P-NAME',12,1,PNAME)
      IF(PNAME.EQ.'T-FUEL') THEN
        CALL LCMGET(KPMAP,'P-TYPE',ITYPE)
        ALLOCATE(VAL(NCH*NB))
        IF(ITYPE.EQ.1) THEN
          IF(IMPX.GT.0) WRITE(6,410) 'GLOBAL',PNAME
          CALL LCMGET(KPMAP,'P-VALUE',FLOT)
          DO 100 ICH=1,NCH
          DO 100 IB=1,NB
          IMA=(IB-1)*NCH+ICH
  100     VAL(IMA)=FLOT
        ELSE IF(ITYPE.EQ.2) THEN
          IF(IMPX.GT.0) WRITE(6,410) 'LOCAL',PNAME
          CALL LCMGET(KPMAP,'P-VALUE',VAL)
        ENDIF
        ICH=0
        DO 140 IY=1,NY
        DO 140 IX=1,NX
        IEL=(IY-1)*NX+IX
        DO 110 IZ=1,NZ
        IF(NUM((IZ-1)*NX*NY+IEL).NE.0) GO TO 120
  110   CONTINUE
        GO TO 140
  120   ICH=ICH+1
        IB=0
        DO 130 IZ=1,NZ
        IF(NUM((IZ-1)*NX*NY+IEL).EQ.0) GO TO 130
        IB=IB+1
        IMA=(IB-1)*NCH+ICH
        ITH=(IZ-1)*IC*JC+(IY-1)*IC+IX
        TCOMB(ITH)=VAL(IMA)
  130   CONTINUE
  140   CONTINUE
        DEALLOCATE(VAL)
      ENDIF
  150 CONTINUE
*---- 
*  TEST TO COMPUTE STATIC OR TRANSIENT CALCULATION
*----
      IF(ITIME.EQ.0) THEN
         GO TO 160
      ELSE IF(ITIME.EQ.1) THEN
         GO TO 210
      ELSE
         CALL XABORT('@THM: UNEXPECTED VALUE FOR ITIME.')
      ENDIF
*----
*  CALL DRIVER FOR STATIC CALCULATION
*----
*     memory allocation for the static calculation
  160 ALLOCATE(TCENT(IC*JC*KC),DCOOL(IC*JC*KC),TCOOL(IC*JC*KC),
     > TSURF(IC*JC*KC),VCOOL(IC*JC*KC),PCOOL(IC*JC*KC),HCOOL(IC*JC*KC),
     > TCODI(IC*JC*KC*NDTOT),DLIQU(IC*JC*KC))
      CALL XDRSET(TCENT,IC*JC*KC,0.0)
      CALL XDRSET(DCOOL,IC*JC*KC,0.0)
      CALL XDRSET(TCOOL,IC*JC*KC,0.0)
      CALL XDRSET(TSURF,IC*JC*KC,0.0)
      CALL XDRSET(VCOOL,IC*JC*KC,0.0)
      CALL XDRSET(PCOOL,IC*JC*KC,0.0)
      CALL XDRSET(HCOOL,IC*JC*KC,0.0)
      CALL XDRSET(TCODI,IC*JC*KC*NDTOT,1.0)
      CALL XDRSET(DLIQU,IC*JC*KC,0.0)
*----
*  EXECUTION OF THE STATIC DRIVER PROGRAM
*----
      CALL THMDRV(IMPX,IC,JC,KC,XBURN,HX,HY,HZ,CFLUX,POROS,NFU,NFD,
     > NDTOT,SASS,FCOOL,FFUEL,ACOOL,HD,PCH,RGG,RIG,RC,MAXIT1,MAXIT2,
     > ERMAXT,SPEED,TINLET,POULET,FRACPU,ICONDF,NCONDF,KCONDF,UCONDF,
     > ICONDC,NCONDC,KCONDC,UCONDC,IHGAP,KHGAP,IHCONV,KHCONV,WTEFF,
     > IFRCDI,ISUBM,POW,TCOMB,DCOOL,TCOOL,TSURF,HCOOL,VCOOL,PCOOL,
     > TCODI,TCENT,DLIQU)
*----
*  MODIFICATION OF THE VECTORS TO FIT THE GEOMETRY OF THE CHANNELS AND
*  THE BUNDLES AND WRITE THE DATA IN LCM OBJECT THM 
*----
      JPTHM=LCMDID(IPTHM,'HISTORY-DATA')
      KPTHM=LCMDID(JPTHM,'STATIC-PARAM')
      ICH=0
      DO 200 IY=1,NY
      DO 200 IX=1,NX
        IEL=IX+(IY-1)*NX
        DO 170 IZ=1,NZ
          IF(NUM((IZ-1)*NX*NY+IEL).NE.0) GO TO 180
  170   CONTINUE
        GO TO 200
  180   ICH=ICH+1
        WRITE(TXTDIR,'(8HCHANNEL ,I4.4)') ICH
        MPTHM=LCMDID(KPTHM,TXTDIR)
        IB=0
        DO 190 IZ=1,NZ
          IF(NUM((IZ-1)*NX*NY+IEL).EQ.0) GO TO 190
          IB=IB+1
          IF(IB.GT.NB) CALL XABORT('@THM: NB OVERFLOW')
          PVAL(IB)=PCOOL((IZ-1)*NX*NY+IEL)
          DVAL(IB)=DCOOL((IZ-1)*NX*NY+IEL)*1000
          HVAL(IB)=HCOOL((IZ-1)*NX*NY+IEL)
          VVAL(IB)=VCOOL((IZ-1)*NX*NY+IEL)
          TCVAL(IB)=TCENT((IZ-1)*NX*NY+IEL)
          DLVAL(IB)=DLIQU((IZ-1)*NX*NY+IEL)
          DO IFD=1,NDTOT
            TVAL((IB-1)*NDTOT+IFD)
     >            =TCODI((IZ-1)*NX*NY+IEL+(IFD-1)*NX*NY*NZ)
          ENDDO          
          IF(IB.EQ.NB) THEN
            CALL LCMPUT(MPTHM,'PRESSURE',NB,2,PVAL)
            CALL LCMPUT(MPTHM,'DENSITY',NB,2,DVAL)
            CALL LCMPUT(MPTHM,'LIQUID-DENS',NB,2,DLVAL)
            CALL LCMPUT(MPTHM,'ENTHALPY',NB,2,HVAL)
            CALL LCMPUT(MPTHM,'VELOCITIES',NB,2,VVAL)
            CALL LCMPUT(MPTHM,'CENTER-TEMPS',NB,2,TCVAL)
            CALL LCMPUT(MPTHM,'TEMPERATURES',NB*NDTOT,2,TVAL)
            CALL LCMPUT(MPTHM,'PINLET',1,2,POULET)
            CALL LCMPUT(MPTHM,'TINLET',1,2,TINLET)
            CALL LCMPUT(MPTHM,'VINLET',1,2,SPEED)
            CALL LCMSIX(MPTHM,' ',2)
          ELSE
          GO TO 190
          ENDIF
  190   CONTINUE
  200 CONTINUE
      DEALLOCATE(VCOOL,PCOOL,HCOOL,TCODI,TCENT,DLIQU)
      GO TO 300
*----
* CALL DRIVER FOR TRANSIENT CALCULATION
*----
*     memory allocation for the transient calculation
  210 ALLOCATE(DCOOL(IC*JC*KC),TCOOL(IC*JC*KC),TSURF(IC*JC*KC),
     > VELOI(IC*JC*KC),DENSI(IC*JC*KC),PRESI(IC*JC*KC),ENTHI(IC*JC*KC),
     > TEMPI(IC*JC*KC*NDTOT),CENTI(IC*JC*KC),DLIQI(IC*JC*KC))
      CALL XDRSET(DCOOL,IC*JC*KC,0.0)
      CALL XDRSET(TCOOL,IC*JC*KC,0.0)
      CALL XDRSET(TSURF,IC*JC*KC,0.0)
      CALL XDRSET(VELOI,IC*JC*KC,0.0)
      CALL XDRSET(DENSI,IC*JC*KC,0.0)
      CALL XDRSET(PRESI,IC*JC*KC,0.0)
      CALL XDRSET(ENTHI,IC*JC*KC,0.0)
      CALL XDRSET(TEMPI,IC*JC*KC*NDTOT,1.0)
      CALL XDRSET(CENTI,IC*JC*KC,0.0)
      CALL XDRSET(DLIQI,IC*JC*KC,0.0)
*----
*  RECOVER DATA FROM FORMER TIME STEP OR STATIC CALCULATION IN THM
*----
      JPTHM=LCMDID(IPTHM,'HISTORY-DATA')
      IF(TIMEIT.EQ.1) THEN
         KPTHM=LCMDID(JPTHM,'STATIC-PARAM')
      ELSE
         TPREV=TIMEIT-1
         WRITE(TXTDIR,'(8HTIMESTEP,I4.4)') TPREV
         KPTHM=LCMDID(JPTHM,TXTDIR)
      ENDIF
      ICH=0
      DO 250 IY=1,NY
      DO 250 IX=1,NX
      IEL=IX+(IY-1)*NX
        DO 220 IZ=1,NZ
          IF(NUM((IZ-1)*NX*NY+IEL).NE.0) GO TO 230
  220   CONTINUE
        GO TO 250
  230   ICH=ICH+1
        WRITE(TXTDIR,'(8HCHANNEL ,I4.4)') ICH
        MPTHM=LCMDID(KPTHM,TXTDIR)
        CALL LCMGET(MPTHM,'DENSITY',DVAL)
        CALL LCMGET(MPTHM,'PRESSURE',PVAL)
        CALL LCMGET(MPTHM,'ENTHALPY',HVAL)
        CALL LCMGET(MPTHM,'VELOCITIES',VVAL)
        CALL LCMGET(MPTHM,'CENTER-TEMPS',TCVAL)
        CALL LCMGET(MPTHM,'TEMPERATURES',TVAL)
        CALL LCMGET(MPTHM,'LIQUID-DENS',DLVAL)
        CALL LCMGET(MPTHM,'PINLET',PIN0)
        CALL LCMGET(MPTHM,'TINLET',TIN0)
        IB=0
        DO 240 IZ=1,NZ
          IF(NUM((IZ-1)*NX*NY+IEL).EQ.0) GO TO 240
          IB=IB+1
          IF(IB.GT.NB) CALL XABORT('@THM: NB OVERFLOW')
          DENSI((IZ-1)*NX*NY+IEL)=DVAL(IB)
          PRESI((IZ-1)*NX*NY+IEL)=PVAL(IB)
          ENTHI((IZ-1)*NX*NY+IEL)=HVAL(IB)
          VELOI((IZ-1)*NX*NY+IEL)=VVAL(IB)
          CENTI((IZ-1)*NX*NY+IEL)=TCVAL(IB)
          DLIQI((IZ-1)*NX*NY+IEL)=DLVAL(IB)
          DO IFD=1,NDTOT
            TEMPI((IZ-1)*NX*NY+IEL+(IFD-1)*NX*NY*NZ)
     >      =TVAL((IB-1)*NDTOT+IFD)
          ENDDO
  240   CONTINUE
        CALL LCMSIX(MPTHM,' ',2)
  250 CONTINUE
      CALL LCMSIX(KPTHM,' ',2)
*
      ALLOCATE(VELOF(IC*JC*KC),DENSF(IC*JC*KC),PRESF(IC*JC*KC),
     > ENTHF(IC*JC*KC),TEMPF(IC*JC*KC*NDTOT),CENTF(IC*JC*KC),
     > DLIQF(IC*JC*KC))
      CALL XDRSET(VELOF,IC*JC*KC,0.0)
      CALL XDRSET(DENSF,IC*JC*KC,0.0)
      CALL XDRSET(PRESF,IC*JC*KC,0.0)
      CALL XDRSET(ENTHF,IC*JC*KC,0.0)
      CALL XDRSET(TEMPF,IC*JC*KC*NDTOT,1.0)
      CALL XDRSET(CENTF,IC*JC*KC,0.0)
      CALL XDRSET(DLIQF,IC*JC*KC,0.0)
*----
*  EXECUTION OF THE TRANSIENT DRIVER PROGRAM
*----
      CALL THMTRS(IMPX,IC,JC,KC,NB,XBURN,HX,HY,HZ,DTIME,CFLUX,POROS,
     > NFU,NFD,NDTOT,SASS,FCOOL,FFUEL,ACOOL,HD,PCH,RGG,RIG,RC,MAXIT3,
     > MAXIT1,MAXIT2,ERMAXT,ERMAXC,TIN0,PIN0,SPEED,TINLET,POULET,
     > FRACPU,ICONDF,NCONDF,KCONDF,UCONDF,ICONDC,NCONDC,KCONDC,UCONDC,
     > IHGAP,KHGAP,IHCONV,KHCONV,WTEFF,IFRCDI,ISUBM,POW,VELOI,DENSI,
     > PRESI,ENTHI,TEMPI,CENTI,DLIQI,TCOMB,DCOOL,TCOOL,TSURF,VELOF,
     > DENSF,PRESF,ENTHF,TEMPF,CENTF,DLIQF,PINLET)
*----
*  MODIFICATION OF THE VECTORS TO FIT THE GEOMETRY OF THE CHANNELS AND
*  THE BUNDLES AND WRITE THE DATA IN LCM OBJECT THM 
*----
      JPTHM=LCMDID(IPTHM,'HISTORY-DATA')
      WRITE(TXTDIR,'(8HTIMESTEP,I4.4)') TIMEIT
      KPTHM=LCMDID(JPTHM,TXTDIR)
      ICH=0
      DO 290 IY=1,NY
      DO 290 IX=1,NX
        IEL=IX+(IY-1)*NX
        DO 260 IZ=1,NZ
          IF(NUM((IZ-1)*NX*NY+IEL).NE.0) GO TO 270
  260   CONTINUE
        GO TO 290
  270   ICH=ICH+1
        WRITE(TXTDIR,'(8HCHANNEL ,I4.4)') ICH
        MPTHM=LCMDID(KPTHM,TXTDIR)
        IB=0
        DO 280 IZ=1,NZ
          IF(NUM((IZ-1)*NX*NY+IEL).EQ.0) GO TO 280
          IB=IB+1
          IF(IB.GT.NB) CALL XABORT('@THM: NB OVERFLOW')
          PVAL(IB)=PRESF((IZ-1)*NX*NY+IEL)
          DVAL(IB)=DENSF((IZ-1)*NX*NY+IEL)
          HVAL(IB)=ENTHF((IZ-1)*NX*NY+IEL)
          VVAL(IB)=VELOF((IZ-1)*NX*NY+IEL)
          TCVAL(IB)=CENTF((IZ-1)*NX*NY+IEL)
          DLVAL(IB)=DLIQF((IZ-1)*NX*NY+IEL)
          DO IFD=1,NDTOT
            TVAL((IB-1)*NDTOT+IFD)
     >            =TEMPF((IZ-1)*NX*NY+IEL+(IFD-1)*NX*NY*NZ)
          ENDDO
          IF(IB.EQ.NB) THEN
            CALL LCMPUT(MPTHM,'PRESSURE',NB,2,PVAL)
            CALL LCMPUT(MPTHM,'DENSITY',NB,2,DVAL)
            CALL LCMPUT(MPTHM,'ENTHALPY',NB,2,HVAL)
            CALL LCMPUT(MPTHM,'VELOCITIES',NB,2,VVAL)
            CALL LCMPUT(MPTHM,'CENTER-TEMPS',NB,2,TCVAL)
            CALL LCMPUT(MPTHM,'TEMPERATURES',NB*NDTOT,2,TVAL)
            CALL LCMPUT(MPTHM,'LIQUID-DENS',NB,2,DLVAL)
            CALL LCMPUT(MPTHM,'PINLET',1,2,PINLET)
            CALL LCMPUT(MPTHM,'TINLET',1,2,TINLET)
            CALL LCMPUT(MPTHM,'VINLET',1,2,SPEED)
            CALL LCMSIX(MPTHM,' ',2)
          ELSE
          GO TO 280
          ENDIF
  280   CONTINUE
  290 CONTINUE
*
      DEALLOCATE(VELOI,DENSI,PRESI,ENTHI,TEMPI,CENTI,DLIQI,VELOF,DENSF,
     > PRESF,ENTHF,TEMPF,CENTF,DLIQF)
*----
*  RECOVER LOCAL PARAMETER INFORMATION COMPUTED BY THMDRV OR THMTRS
*----
  300 ERRA1=0.0
      ERRA2=0.0
      ERRA3=0.0
      ERRBB=0.0
      ZMINA1=1.0E10
      ZMINA2=1.0E10
      ZMINA3=1.0E10
      ZMINBB=1.0E10
      ZMAXA1=0.0
      ZMAXA2=0.0
      ZMAXA3=0.0
      ZMAXBB=0.0
      JPMAP=LCMGID(IPMAP,'PARAM')
      DO 360 IPAR=1,NPARM
      KPMAP=LCMGIL(JPMAP,IPAR)
      CALL LCMGTC(KPMAP,'P-NAME',12,1,PNAME)
      IF((PNAME.EQ.'T-FUEL').OR.(PNAME.EQ.'D-COOL').OR.
     1   (PNAME.EQ.'T-COOL').OR.(PNAME.EQ.'T-SURF')) THEN
        CALL LCMGET(KPMAP,'P-TYPE',ITYPE)
        ALLOCATE(VAL(NCH*NB))
        RELAX0=1.0
        IF(ITYPE.EQ.1) THEN
          IF(IMPX.GT.0) WRITE(6,410) 'GLOBAL',PNAME
          CALL LCMGET(KPMAP,'P-VALUE',FLOT)
          DO 310 ICH=1,NCH
          DO 310 IB=1,NB
  310     VAL((IB-1)*NCH+ICH)=FLOT
        ELSE IF(ITYPE.EQ.2) THEN
          RELAX0=RELAX
          IF(IMPX.GT.0) WRITE(6,410) 'LOCAL',PNAME
          CALL LCMGET(KPMAP,'P-VALUE',VAL)
        ENDIF
        ICH=0
        DO 350 IY=1,NY
        DO 350 IX=1,NX
        IEL=(IY-1)*NX+IX
        DO 320 IZ=1,NZ
        IF(NUM((IZ-1)*NX*NY+IEL).NE.0) GO TO 330
  320   CONTINUE
        GO TO 350
  330   ICH=ICH+1
        IB=0
        DO 340 IZ=1,NZ
        IF(NUM((IZ-1)*NX*NY+IEL).EQ.0) GO TO 340
        IB=IB+1
        IMA=(IB-1)*NCH+ICH
        ITH=(IZ-1)*IC*JC+(IY-1)*IC+IX
        FLOT=0.0
        IF(PNAME.EQ.'T-FUEL') THEN
          FLOT=RELAX0*TCOMB(ITH)+(1.0-RELAX0)*VAL(IMA)
          ERRA1=MAX(ERRA1,ABS(VAL(IMA)-FLOT))
          ZMINA1=MIN(ZMINA1,FLOT)
          ZMAXA1=MAX(ZMAXA1,FLOT)
        ELSE IF(PNAME.EQ.'D-COOL') THEN
          FLOT=RELAX0*DCOOL(ITH)+(1.0-RELAX0)*VAL(IMA)
          ERRA2=MAX(ERRA2,ABS(VAL(IMA)-FLOT))
          ZMINA2=MIN(ZMINA2,FLOT)
          ZMAXA2=MAX(ZMAXA2,FLOT)
        ELSE IF(PNAME.EQ.'T-COOL') THEN
          FLOT=RELAX0*TCOOL(ITH)+(1.0-RELAX0)*VAL(IMA)
          ERRA3=MAX(ERRA3,ABS(VAL(IMA)-FLOT))
          ZMINA3=MIN(ZMINA3,FLOT)
          ZMAXA3=MAX(ZMAXA3,FLOT)
        ELSE IF(PNAME.EQ.'T-SURF') THEN
          FLOT=RELAX0*TSURF(ITH)+(1.0-RELAX0)*VAL(IMA)
          ERRBB=MAX(ERRBB,ABS(VAL(IMA)-FLOT))
          ZMINBB=MIN(ZMINBB,FLOT)
          ZMAXBB=MAX(ZMAXBB,FLOT)
        ELSE
          CALL XABORT('@THM: INVALID PARAMETER TYPE: '// PNAME//'.')
        ENDIF
        VAL(IMA)=FLOT
  340   CONTINUE
  350   CONTINUE
        ITYPE=2
        CALL LCMPUT(KPMAP,'P-TYPE',1,1,ITYPE)
        CALL LCMPUT(KPMAP,'P-VALUE',NCH*NB,2,VAL)
        DEALLOCATE(VAL)
      ENDIF
      IF(PNAME.EQ.'T-FUEL') THEN
        CALL LCMPUT(IPTHM,'ERROR-T-FUEL',1,2,ERRA1)
        CALL LCMPUT(IPTHM,'MIN-T-FUEL',1,2,ZMINA1)
        CALL LCMPUT(IPTHM,'MAX-T-FUEL',1,2,ZMAXA1)
        IF(IMPX.GT.0) WRITE(6,420) 'FUEL TEMPERATURE',ERRA1,'C',
     1  ZMINA1,'C',ZMAXA1,'C'
      ELSE IF(PNAME.EQ.'D-COOL') THEN
        CALL LCMPUT(IPTHM,'ERROR-D-COOL',1,2,ERRA2)
        CALL LCMPUT(IPTHM,'MIN-D-COOL',1,2,ZMINA2)
        CALL LCMPUT(IPTHM,'MAX-D-COOL',1,2,ZMAXA2)
        IF(IMPX.GT.0) WRITE(6,420) 'COOLANT DENSITY',ERRA2,'G/CC',
     1  ZMINA2,'G/CC',ZMAXA2,'G/CC'
      ELSE IF(PNAME.EQ.'T-COOL') THEN
        CALL LCMPUT(IPTHM,'ERROR-T-COOL',1,2,ERRA3)
        CALL LCMPUT(IPTHM,'MIN-T-COOL',1,2,ZMINA3)
        CALL LCMPUT(IPTHM,'MAX-T-COOL',1,2,ZMAXA3)
        IF(IMPX.GT.0) WRITE(6,420) 'COOLANT TEMPERATURE',ERRA3,'C',
     1  ZMINA3,'C',ZMAXA3,'C'
      ELSE IF(PNAME.EQ.'T-SURF') THEN
        CALL LCMPUT(IPTHM,'ERROR-T-SURF',1,2,ERRBB)
        IF(IMPX.GT.0) WRITE(6,420) 'FUEL SURFACE TEMPERATURE',ERRBB,
     1  'C',ZMINBB,'C',ZMAXBB,'C'
      ENDIF
  360 CONTINUE
*----
*  SAVE CONDUCTIVITY INFORMATION ON LCM OBJECT THM
*----
      IF(ICONDF.EQ.1) THEN
        CALL LCMPUT(IPTHM,'KCONDF',NCONDF+3,2,KCONDF)
        CALL LCMPTC(IPTHM,'UCONDF',12,1,UCONDF)
      ENDIF
      IF(ICONDC.EQ.1) THEN
        CALL LCMPUT(IPTHM,'KCONDC',NCONDC+1,2,KCONDC)
        CALL LCMPTC(IPTHM,'UCONDC',12,1,UCONDC)
      ENDIF
*----
*  RELEASE MEMORY
*----
      DEALLOCATE(TCOMB,DCOOL,TCOOL,TSURF)
      DEALLOCATE(NUM)
      DEALLOCATE(POW,XBURN)
      IF(ICONDF.EQ.1)DEALLOCATE(KCONDF)
      IF(ICONDC.EQ.1)DEALLOCATE(KCONDC)
*----
*  STATE-VECTOR FOR THM
*----
      HSIGN='L_THM'
      CALL LCMPTC(IPTHM,'SIGNATURE',12,1,HSIGN)
      CALL XDISET(ISTATE,NSTATE,0)
      ISTATE(1)=NFU
      ISTATE(2)=NTG
      ISTATE(3)=MAXIT1
      ISTATE(4)=MAXIT2
      ISTATE(5)=MAXIT3
      ISTATE(6)=NFD
      ISTATE(7)=NDTOT
      ISTATE(8)=ITIME
      ISTATE(9)=TIMEIT
      ISTATE(10)=IHGAP
      ISTATE(11)=IHCONV
      ISTATE(12)=ICONDF
      ISTATE(13)=ICONDC
      ISTATE(14)=IFRCDI
      ISTATE(15)=ISUBM
      IF(ICONDF.EQ.1) ISTATE(16)=NCONDF
      IF(ICONDC.EQ.1) ISTATE(17)=NCONDC
      CALL LCMPUT(IPTHM,'STATE-VECTOR',NSTATE,1,ISTATE)
      CALL XDRSET(STATE,NSTATE,0.0)
      STATE(1)=DTIME
      STATE(2)=FPUISS
      STATE(3)=CFLUX
      STATE(4)=SPEED
      STATE(5)=POULET
      STATE(6)=TINLET
      STATE(7)=FRACPU
      STATE(8)=POROS
      STATE(9)=RC
      STATE(10)=RIG
      STATE(11)=RGG
      STATE(12)=RTG
      STATE(13)=SASS
      STATE(14)=ERMAXT
      STATE(15)=ERMAXC
      STATE(16)=RELAX
      STATE(17)=RTIME
      IF(IHGAP.EQ.1) STATE(18)=KHGAP
      IF(IHCONV.EQ.1) STATE(19)=KHCONV
      STATE(20)=WTEFF
      CALL LCMPUT(IPTHM,'REAL-PARAM',NSTATE,2,STATE)
      IF(IMPX.GT.0) THEN
         WRITE(6,440) (ISTATE(ITC),ITC=1,15)
         IF(ISTATE(12).EQ.1) WRITE(6,450) (ISTATE(16))
         IF(ISTATE(13).EQ.1) WRITE(6,460) (ISTATE(17))
         WRITE(6,470) (STATE(ITC),ITC=1,17)
         IF(ISTATE(10).EQ.1) WRITE(6,480) (STATE(18))
         IF(ISTATE(11).EQ.1) WRITE(6,490) (STATE(19))
      ENDIF
      IF(IMPX.GT.2) CALL LCMLIB(IPTHM)
      RETURN
*
  400 FORMAT(/27H THM: SET GLOBAL PARAMETER ,A,2H =,1P E12.4)
  410 FORMAT(/14H THM: RECOVER ,A,13H PARAMETER = ,A,1H.)
  420 FORMAT(/15H THM: ERROR ON ,A,2H =,F12.3,1X,A,13H  MIN VALUE =,
     1 F12.3,1X,A,13H  MAX VALUE =,F12.3,1X,A)
  440 FORMAT(/
     1 14H STATE VECTOR:/
     2 7H NFU   ,I9,31H   (NUMBER OF ACTIVE FUEL RODS)/
     3 7H NTG   ,I9,32H   (NUMBER OF RODS WITHOUT FUEL)/
     4 7H MAXIT1,I9,36H   (NUMBER OF CONDUCTION ITERATIONS)/
     5 7H MAXIT2,I9,39H   (NUMBER OF CENTER-PELLET ITERATIONS)/
     6 7H MAXIT3,I9,30H   (NUMBER OF FLOW ITERATIONS)/
     7 7H NFD   ,I9,32H   (NUMBER OF FUEL RADIAL ZONES)/
     8 7H NDTOT ,I9,36H   (NUMBER OF DISCRETISATION POINTS)/
     9 7H ITIME ,I9,21H   (CALCULATION TYPE)/
     1 7H TIMEIT,I9,31H   (TRANSIENT ITERATION NUMBER)/
     2 7H IHGAP ,I9,34H   (HGAP FLAG (0=DEFAULT/1=FIXED))/
     3 7H IHCONV,I9,42H   (HCONV FLAG (0=DITTUS-BOELTER/1=FIXED))/
     4 7H ICONDF,I9,46H   (FUEL CONDUCTIVITY FLAG (0=STORA-CHENEBAULT,
     5 54H (UOX), COMETHE (MOX)/1=USER-PROVIDED FUNCTION OF FUEL,
     6 14H TEMPERATURE))/
     7 7H ICONDC,I9,39H   (CLAD CONDUCTIVITY FLAG (0=DEFAULT/1,
     8 47H=USER-PROVIDED POLYNOMIAL OF CLAD TEMPERATURE))/
     9 7H IFRCDI,I9,40H   (FUEL CONDUCTIVITY APPROXIMATION FLAG,
     1 44H (0=DEFAULT/1=AVERAGE APPROXIMATION FORCED))/
     2 7H ISUBM ,I9,47H   (SUBCOOLING MODEL FLAG (0=BOWRING MODEL/1=SA,
     3 22HHA-ZUBER CORRELATION)))
  450 FORMAT(
     1 7H NCONDF,I9,43H   (DEGREE OF FUEL CONDUCTIVITY POLYNOMIAL))
  460 FORMAT(
     1 7H NCONDC,I9,43H   (DEGREE OF CLAD CONDUCTIVITY POLYNOMIAL))
  470 FORMAT(/
     1 12H REAL PARAM:,1P/
     2 7H DTIME ,E12.4,19H   (TIME STEP IN S)/
     2 7H FPUISS,E12.4,25H   (COOLANT POWER FACTOR)/
     2 7H CFLUX ,E12.4,32H   (CRITICAL HEAT FLUX IN W/M^2)/
     2 7H SPEED ,E12.4,28H   (COOLANT VELOCITY IN M/S)/
     2 7H POULET,E12.4,34H   (OUTLET COOLANT PRESSURE IN PA)/
     2 7H TINLET,E12.4,35H   (INLET COOLANT TEMPERATURE IN K)/
     2 7H FRACPU,E12.4,30H   (PLUTONIUM MASS ENRICHMENT)/
     2 7H POROS ,E12.4,19H   (OXYDE POROSITY)/
     2 7H RC    ,E12.4,28H   (FUEL PELLET RADIUS IN M)/
     2 7H RIG   ,E12.4,34H   (INTERNAL CLAD ROD RADIUS IN M)/
     2 7H RGG   ,E12.4,34H   (EXTERNAL CLAD ROD RADIUS IN M)/
     2 7H RTG   ,E12.4,27H   (GUIDE TUBE RADIUS IN M)/
     2 7H SASS  ,E12.4,28H   (ASSEMBLY SURFACE IN M^2)/
     2 7H ERMAXT,E12.4,35H   (TEMPERATURE MAXIMUM ERROR IN K)/
     2 7H ERMAXC,E12.4,32H   (FLOW MAXIMUM RELATIVE ERROR)/
     2 7H RELAX ,E12.4,25H   (RELAXATION PARAMETER)/
     2 7H RTIME ,E12.4,20H   (TIME VALUE IN S)/
     2 7H WTEFF ,E12.4,44H   (SURFACE TEMPERATURE WEIGHTING FACTOR IN ,
     2 27HEFFECTIVE FUEL TEMPERATURE))
  480 FORMAT(
     1 7H HGAP  ,E12.4,20H   (HGAP IN W/M^2/K))
  490 FORMAT(
     1 7H HCONV ,E12.4,21H   (HCONV IN W/M^2/K))
      END
