*DECK USS
      SUBROUTINE USS(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Universal self-shielding operator.
*
*Copyright:
* Copyright (C) 2002 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/output
* NENTRY  number of LCM objects or files used by the operator.
* HENTRY  name of each LCM object or file:
*         HENTRY(1): creation or modification type(L_LIBRARY) (no
*         subgroups);
*         HENTRY(2): read-only type(L_LIBRARY) (with subgroups);
*         HENTRY(3): read-only type(L_TRACK);
*         HENTRY(4): optional read-only sequential binary tracking file.
* 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,MAXRSS=300,IOUT=6)
      TYPE(C_PTR) IPLI0,IPLIB,IPTRK
      CHARACTER TEXT4*4,HSIGN*12,TEXT12*12,HSMG*131,CDOOR*12,TITR*72,
     1 HISOT*12
      DOUBLE PRECISION DFLOTT
      LOGICAL LEAKSW,LFLAT
      INTEGER IGP(NSTATE),IPAR(NSTATE),IPAS(NSTATE),IRSS(MAXRSS)
*----
*  PARAMETER VALIDATION.
*----
      IF(NENTRY.LE.2) CALL XABORT('USS: THREE PARAMETERS EXPECTED.')
      IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('USS: LI'
     1 //'NKED LIST OR XSM FILE EXPECTED AT LHS.')
      IF((JENTRY(1).NE.0).AND.(JENTRY(1).NE.1)) CALL XABORT('USS: EN'
     1 //'TRY IN CREATE OR MODIFICATION MODE EXPECTED.')
      IF((JENTRY(2).NE.2).OR.((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2)))
     1 CALL XABORT('USS: LINKED LIST OR XSM FILE IN READ-ONLY MODE E'
     2 //'XPECTED AT FIRST RHS.')
      IF((JENTRY(3).NE.2).OR.((IENTRY(3).NE.1).AND.(IENTRY(3).NE.2)))
     1 CALL XABORT('USS: LINKED LIST OR XSM FILE IN READ-ONLY MODE E'
     2 //'XPECTED AT SECOND RHS.')
      CALL LCMGTC(KENTRY(3),'SIGNATURE',12,1,HSIGN)
      IF(HSIGN.NE.'L_TRACK') THEN
         TEXT12=HENTRY(3)
         CALL XABORT('USS: SIGNATURE OF '//TEXT12//' IS '//HSIGN//
     1   '. L_TRACK EXPECTED.')
      ENDIF
      CALL LCMGTC(KENTRY(3),'TRACK-TYPE',12,1,CDOOR)
      IPLI0=KENTRY(1)
      IPLIB=KENTRY(2)
      IPTRK=KENTRY(3)
      IF(JENTRY(1).EQ.0) THEN
         INDREC=1
         HSIGN='L_LIBRARY'
         CALL LCMPTC(IPLI0,'SIGNATURE',12,1,HSIGN)
      ELSE IF(JENTRY(1).EQ.1) THEN
         CALL LCMGTC(IPLI0,'SIGNATURE',12,1,HSIGN)
         IF(HSIGN.NE.'L_LIBRARY') THEN
            TEXT12=HENTRY(1)
            CALL XABORT('USS: SIGNATURE OF '//TEXT12//' IS '//HSIGN//
     1      '. L_LIBRARY EXPECTED.')
         ENDIF
         INDREC=2
      ENDIF
*----
*  RECOVER TABULATED FUNCTIONS.
*----
      CALL XDRTA2(IPTRK)
*----
*  RECOVER TRACKING FILE INFORMATION.
*----
      IF(NENTRY.LT.4) THEN
        IFTRAK=0
      ELSE
        TEXT12=HENTRY(4)
        IF(IENTRY(4).EQ.3) THEN
          IF(JENTRY(4).NE.2) CALL XABORT('USS: BINARY TRACKING FILE NA'
     1    //'MED '//TEXT12//' IS NOT IN REAL-ONLY MODE.')
          IFTRAK=FILUNIT(KENTRY(4))
        ENDIF
      ENDIF
*----
*  RECOVER GENERAL TRACKING INFORMATION.
*----
      CALL LCMGET(IPTRK,'STATE-VECTOR',IGP)
      NREG=IGP(1)
      NUN=IGP(2)
      LEAKSW=IGP(3).EQ.0
      CALL LCMLEN(IPTRK,'TITLE',LENGT,ITYLCM)
      IF(LENGT.GT.0) THEN
         CALL LCMGTC(IPTRK,'TITLE',72,1,TITR)
      ELSE
         TITR='*** NO TITLE PROVIDED ***'
      ENDIF
*----
*  RECOVER INTERNAL LIBRARY PARAMETERS.
*----
      CALL LCMGTC(IPLIB,'SIGNATURE',12,1,HSIGN)
      IF(HSIGN.NE.'L_LIBRARY') THEN
         TEXT12=HENTRY(2)
         CALL XABORT('USS: SIGNATURE OF '//TEXT12//' IS '//HSIGN//
     1   '. L_LIBRARY EXPECTED.')
      ENDIF
      CALL LCMGET(IPLIB,'STATE-VECTOR',IPAR)
      NBISO=IPAR(2)
      NGRP=IPAR(3)
      NL=IPAR(4)
      ITRANC=IPAR(5)
      IGRMIN=IPAR(9)+1
      IGRMAX=IPAR(10)
      NED=IPAR(13)
      NBMIX=IPAR(14)
      NRES=IPAR(15)
      ISUBG=IPAR(17)
      NDEL=IPAR(19)
      IF(IGP(4).GT.NBMIX) THEN
         WRITE(HSMG,'(45HUSS: THE NUMBER OF MIXTURES IN THE TRACKING (,
     1   I5,55H) IS GREATER THAN THE NUMBER OF MIXTURES IN THE INTERNA,
     2   11HL LIBRARY (,I5,2H).)') IGP(4),NBMIX
         CALL XABORT(HSMG)
      ELSE IF((ISUBG.LE.0).OR.(ISUBG.EQ.2)) THEN
         CALL XABORT('USS: THE INPUT INTERNAL LIBRARY HAS NO SUBGROUP'
     1   //'S.')
      ENDIF
      IF(INDREC.EQ.2) THEN
         CALL LCMGET(IPLI0,'STATE-VECTOR',IPAR)
         IF(IPAR(2).NE.NBISO) CALL XABORT('USS: INVALID LIBRARY.')
      ENDIF
*
      IMPX=1
      LFLAT=.FALSE.
      CALL LCMLEN(IPLI0,'SHIBA_SG',LENLCM,ITYLCM)
      IF(LENLCM.NE.0) THEN
         CALL LCMSIX(IPLI0,'SHIBA_SG',1)
         CALL LCMGET(IPLI0,'STATE-VECTOR',IPAS)
         CALL LCMSIX(IPLI0,' ',2)
         IGRMIN=IPAS(1)
         IGRMAX=IPAS(2)
         KSPH=IPAS(3)
         ITRANZ=IPAS(4)
         NPASS=IPAS(5)
         IPHASE=IPAS(6)
         ICALC=IPAS(8)
         ICORR=IPAS(9)
         MAXST=IPAS(10)
      ELSE
         KSPH=1
         ITRANZ=ITRANC
         NPASS=2
         IF(CDOOR.EQ.'SYBIL') THEN
            IPHASE=2
         ELSE IF(CDOOR.EQ.'EXCELL') THEN
            IPHASE=2
         ELSE
            IPHASE=1
         ENDIF
         ICALC=0
         ICORR=0
         MAXST=50
      ENDIF
*
   30 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT)
      IF(INDIC.EQ.10) GO TO 70
      IF(INDIC.NE.3) CALL XABORT('USS: CHARACTER DATA EXPECTED(1).')
      IF(TEXT4.EQ.'EDIT') THEN
         CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT)
         IF(INDIC.NE.1) CALL XABORT('USS: INTEGER DATA EXPECTED(1).')
      ELSE IF(TEXT4.EQ.'GRMI') THEN
         CALL REDGET(ITYPLU,IGRMIN,FLOTT,TEXT4,DFLOTT)
         IF(ITYPLU.NE.1) CALL XABORT('USS: INTEGER DATA EXPECTED(2).')
      ELSE IF(TEXT4.EQ.'GRMA') THEN
         CALL REDGET(ITYPLU,IGRMAX,FLOTT,TEXT4,DFLOTT)
         IF(ITYPLU.NE.1) CALL XABORT('USS: INTEGER DATA EXPECTED(3).')
         IF(IGRMAX.GT.NGRP) THEN
            CALL XABORT('USS: ILLEGAL NUMBER OF GROUP IN LIBRARY.')
         ENDIF
      ELSE IF(TEXT4.EQ.'NOSP') THEN
         KSPH=0
      ELSE IF(TEXT4.EQ.'NOTR') THEN
         ITRANZ=0
      ELSE IF(TEXT4.EQ.'TRAN') THEN
         ITRANZ=1
      ELSE IF(TEXT4.EQ.'PASS') THEN
         CALL REDGET(ITYPLU,NPASS,FLOTT,TEXT4,DFLOTT)
         IF(ITYPLU.NE.1) CALL XABORT('USS: INTEGER DATA EXPECTED(5).')
         IF(NPASS.LE.0) CALL XABORT('USS: POSITIVE PASS EXPECTED.')
      ELSE IF(TEXT4.EQ.'ARM') THEN
         IPHASE=1
      ELSE IF(TEXT4.EQ.'PIJ') THEN
         IPHASE=2
      ELSE IF(TEXT4.EQ.'CALC') THEN
         ICALC=1
         CALL LCMSIX(IPLI0,'SHIBA_SG',1)
         CALL LCMSIX(IPLI0,'-DATA-CALC-',1)
         CALL REDGET(ITYPLU,NITMA,FLOTT,TEXT12,DFLOTT)
         IF(ITYPLU.NE.3) CALL XABORT('USS: CHARACTER DATA EXPECTED(2).')
   40    IF(TEXT12.EQ.'ENDC') THEN
            CALL LCMSIX(IPLI0,' ',2)
            CALL LCMSIX(IPLI0,' ',2)
            GO TO 30
         ENDIF
         IF(TEXT12.NE.'REGI') CALL XABORT('USS: REGI KEYWORD EXPECTED.')
         CALL REDGET(ITYPLU,NITMA,FLOTT,TEXT12,DFLOTT)
         IF(ITYPLU.NE.3) CALL XABORT('USS: CHARACTER DATA EXPECTED(3).')
         IF(TEXT12(5:).NE.' ') CALL XABORT('USS: 4-CHARACTER NAME EXPE'
     1   //'CTED.')
         CALL LCMSIX(IPLI0,TEXT12(:4),1)
         CALL REDGET(ITYPLU,NITMA,FLOTT,TEXT12,DFLOTT)
         IF(ITYPLU.NE.3) CALL XABORT('USS: CHARACTER DATA EXPECTED(4).')
   50    IF((TEXT12.EQ.'ENDC').OR.(TEXT12.EQ.'REGI')) THEN
            CALL LCMSIX(IPLI0,' ',2)
            GO TO 40
         ENDIF
         HISOT=TEXT12
         NRSS=0
   60    CALL REDGET(ITYPLU,NITMA,FLOTT,TEXT12,DFLOTT)
         IF(ITYPLU.EQ.3) THEN
            IF(TEXT12.EQ.'ALL') THEN
               NRSS=1
               IRSS(1)=-999
               GO TO 60
            ENDIF
            IF(NRSS.EQ.0) CALL XABORT('USS: INTEGER ARRAY EXPECTED.')
            CALL LCMPUT(IPLI0,HISOT,NRSS,1,IRSS)
            GO TO 50
         ENDIF
         IF(ITYPLU.NE.1) CALL XABORT('USS: INTEGER DATA EXPECTED(6).')
         NRSS=NRSS+1
         IF(NRSS.GT.MAXRSS) CALL XABORT('USS: MAXRSS OVERFLOW.')
         IF((NITMA.LE.0).OR.(NITMA.GT.NBMIX)) THEN
            WRITE(HSMG,'(43HUSS: REGI KEYWORD -- INVALID MIXTURE INDEX=,
     1      I5,1H.)') NITMA
            CALL XABORT(HSMG)
         ENDIF
         IRSS(NRSS)=NITMA
         GO TO 60
      ELSE IF(TEXT4.EQ.'NOCO') THEN
         ICORR=1
      ELSE IF(TEXT4.EQ.'MAXS') THEN
         CALL REDGET(ITYPLU,MAXST,FLOTT,TEXT4,DFLOTT)
         IF(ITYPLU.NE.1) CALL XABORT('USS: INTEGER DATA EXPECTED(7).')
      ELSE IF(TEXT4.EQ.'FLAT') THEN
         IF(INDREC.EQ.1) CALL XABORT('USS: OUTPUT MICROLIB IN MODIFICA'
     1   //'TION MODE EXPECTED.')
         LFLAT=.TRUE.
      ELSE IF(TEXT4.EQ.';') THEN
         GO TO 70
      ELSE
         CALL XABORT('USS: '//TEXT4//' IS AN INVALID KEY WORD.')
      ENDIF
      GO TO 30
*----
*  THE NUMBER OF UNKNOWNS OF A CURRENT-BASED SYBIL ITERATION IS
*  INCREASED TO HOLD INTERFACE CURRENT COMPONENTS.
*----
   70 IF((CDOOR.EQ.'SYBIL').AND.(IPHASE.EQ.1)) NUN=NUN+IGP(9)
*----
*  CALL USS: DRIVER.
*----
      IF(IMPX.GT.0) THEN
         IF(INDREC.EQ.1) WRITE(IOUT,100)
         WRITE(IOUT,110) TITR,CDOOR(:9),IGRMIN,IGRMAX,KSPH,ITRANZ,NPASS,
     1   IPHASE,ICALC,ICORR,MAXST
      ENDIF
*----
*  PERFORM SELF-SHIELDING.
*----
      IF(CDOOR.EQ.'MCCG') THEN
         CALL LCMLEN(IPTRK,'KEYFLX',LKFL,ITYLCM)
         NFUNL=LKFL/NREG
      ELSE
         NFUNL=1
      ENDIF
      CALL USSDRV(IPLI0,IPTRK,IPLIB,IFTRAK,INDREC,CDOOR,IMPX,IGRMIN,
     1 IGRMAX,NGRP,NBMIX,NREG,NUN,NBISO,NL,NED,NDEL,LEAKSW,ITRANZ,
     2 IPHASE,TITR,KSPH,NRES,NPASS,ICALC,ICORR,ISUBG,MAXST,LFLAT)
*----
*  STORE THE GENERAL SHELF-SHIELDING PARAMETERS.
*----
      CALL XDISET(IPAS,NSTATE,0)
      IPAS(1)=IGRMIN
      IPAS(2)=IGRMAX
      IPAS(3)=KSPH
      IPAS(4)=ITRANZ
      IPAS(5)=NPASS
      IPAS(6)=IPHASE
      IPAS(8)=ICALC
      IPAS(9)=ICORR
      IPAS(10)=MAXST
      CALL LCMSIX(IPLI0,'SHIBA_SG',1)
      CALL LCMPUT(IPLI0,'STATE-VECTOR',NSTATE,1,IPAS)
      CALL LCMSIX(IPLI0,' ',2)
      RETURN
*
  100 FORMAT(1H1,23HUU   UU  SSSSS   SSSSS ,107(1H*)/
     1 25H UU   UU SSSSSSS SSSSSSS ,63(1H*),
     2 43H UNIVERSAL SELF-SHIELDING MODEL.  A. HEBERT/
     3 24H UU   UU SS   SS SS   SS/21H UU   UU  SSS     SSS/
     4 23H UU   UU    SSS     SSS/24H UU   UU SS   SS SS   SS/
     5 24H UUUUUUU SSSSSSS SSSSSSS/23H  UUUUU   SSSSS   SSSSS/)
  110 FORMAT(/1X,A72//8H OPTIONS/8H -------/
     1 7H CDOOR ,A8,30H   (NAME OF THE SOLUTION DOOR)/
     2 7H IGRMIN,I8,27H   (FIRST GROUP TO PROCESS)/
     3 7H IGRMAX,I8,34H   (MOST THERMAL GROUP TO PROCESS)/
     4 7H KSPH  ,I8,47H   (=0: NO SPH CORRECTION; =1: SPH CORRECTION I,
     5 19HN RESONANT REGIONS)/
     6 7H ITRANZ,I8,45H   (0=NO TRANSPORT CORRECTION/1=APOLLO TYPE/2,
     7 57H=RECOVER FROM LIBRARY/3=WIMS-D TYPE/4=LEAKAGE CORRECTION)/
     8 7H NPASS ,I8,31H   (NUMBER OF OUTER ITERATIONS)/
     9 7H IPHASE,I8,37H   (=1: NATIVE ASSEMBLY; =2: USE PIJ)/
     1 7H ICALC ,I8,48H   (=0: NO &CALC DATA; =1: &CALC DATA AVAILABLE)/
     2 7H ICORR ,I8,47H   (=1: SUPPRESS MUTUAL RESONANCE SHIELDING EFF,
     3 4HECT)/
     4 7H MAXST ,I8,36H   (MAXIMUM NUMBER OF ST ITERATIONS))
      END
