*DECK NCRDRV
      SUBROUTINE NCRDRV(MAXISD,IPCPO,LCUBIC,NMIX,IMPX,NMIL,NCAL,ITER,
     1 MAXNIS,MIXC,TERP,NISO,LISO,HISO,CONC)
*
*-----------------------------------------------------------------------
*
*Purpose:
* compute TERP factors for multicompo interpolation. Use user-defined
* global and local parameters.
*
*Copyright:
* Copyright (C) 2006 Ecole Polytechnique de Montreal
*
*Author(s): A. Hebert and R. Chambon
*
*Parameters: input
* MAXISD  maximum number of isotopes in a mixture.
* IPCPO   address of the multicompo object.
* LCUBIC  =.TRUE.: cubic Ceschino interpolation; =.FALSE: linear
*         Lagrange interpolation.
* NMIX    maximum number of material mixtures in the microlib.
* IMPX    print parameter (equal to zero for no print).
* NMIL    number of material mixtures in the compo.
* NCAL    number of elementary calculations in the compo.
*
*Parameters: output
* ITER    completion flag (=0: all over; =1: use another compo;
*         =2 use another L_MAP + compo).
* MAXNIS  maximum value of NISO(I) in user data.
* MIXC    mixture index in the compo corresponding to each microlib
*         mixture.
* TERP    interpolation factors.
* NISO    number of user-selected isotopes.
* LISO    type of treatment (=.true.: ALL; =.false.: ONLY).
* HISO    name of the user-selected isotopes.
* CONC    user-defined number density of the user-selected isotopes. A
*         value of -99.99 is set to indicate that the compo value is
*         used.
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) IPCPO
      INTEGER MAXISD,NMIX,IMPX,NMIL,NCAL,ITER,MAXNIS,MIXC(NMIX),
     1 NISO(NMIX),HISO(2,NMIX,MAXISD)
      REAL TERP(NCAL,NMIX),CONC(NMIX,MAXISD)
      LOGICAL LCUBIC,LISO(NMIX)
*----
*  LOCAL VARIABLES
*----
      PARAMETER (REPS=1.0E-4,IOUT=6,MAXPAR=50,MAXLIN=50,MAXVAL=200,
     1 NSTATE=40)
      CHARACTER TEXT12*12,PARKEY(MAXPAR)*12,PARFMT(MAXPAR)*8,
     1 PARKEL(MAXPAR)*12,HSMG*131,COMMEN(MAXLIN)*80,VALH(MAXPAR)*12,
     2 RECNAM*12,VCHAR(MAXVAL)*12,HCUBIC*12
      INTEGER ISTATE(NSTATE),VALI(MAXPAR),NVALUE(MAXPAR),VINTE(MAXVAL),
     1 MUPLET(2*MAXPAR),MUTYPE(2*MAXPAR)
      DOUBLE PRECISION DFLOTT
      REAL VALR(2*MAXPAR,2),VREAL(MAXVAL)
      LOGICAL LCUB2(MAXPAR)
      TYPE(C_PTR) JPCPO,KPCPO,LPCPO
      LOGICAL, ALLOCATABLE, DIMENSION(:) :: LDELTA
*----
*  SCRATCH STORAGE ALLOCATION
*----
      ALLOCATE(LDELTA(NMIX))
*----
*  RECOVER TABLE-OF-CONTENT INFORMATION FOR THE COMPO.
*----
      CALL LCMGET(IPCPO,'STATE-VECTOR',ISTATE)
      NPAR=ISTATE(5)
      NLOC=ISTATE(6)
      NCOMLI=ISTATE(10)
      CALL LCMGTC(IPCPO,'COMMENT',80,NCOMLI,COMMEN)
      IF(NPAR.GT.0) THEN
         CALL LCMSIX(IPCPO,'GLOBAL',1)
         CALL LCMGTC(IPCPO,'PARKEY',12,NPAR,PARKEY)
         CALL LCMGTC(IPCPO,'PARFMT',8,NPAR,PARFMT)
         CALL LCMSIX(IPCPO,' ',2)
      ENDIF
      IF(NLOC.GT.0) THEN
         CALL LCMSIX(IPCPO,'LOCAL',1)
         CALL LCMGTC(IPCPO,'PARKEY',12,NLOC,PARKEL)
         CALL LCMSIX(IPCPO,' ',2)
      ENDIF
      IF(IMPX.GT.0) WRITE(IOUT,'(1X,A)') (COMMEN(I),I=1,NCOMLI)
      CALL XDRSET(TERP,NCAL*NMIX,0.0)
      CALL XDISET(MIXC,NMIX,0)
*----
*  READ (INTERP_DATA) AND SET VALI, VALR AND VALH PARAMETERS
*  CORRESPONDING TO THE INTERPOLATION POINT. FILL MUPLET FOR
*  PARAMETERS SET WITHOUT INTERPOLATION.
*----
      IBM=0
      MAXNIS=0
      CALL XDISET(NISO,NMIX,0)
      CALL XDLSET(LISO,NMIX,.TRUE.)
      CALL XDLSET(LDELTA,NMIX,.FALSE.)
   10 CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
      IF(INDIC.NE.3) CALL XABORT('NCRDRV: CHARACTER DATA EXPECTED.')
   20 IF(TEXT12.EQ.'MIX') THEN
         CALL XDISET(MUPLET,NPAR+NLOC,0)
         CALL XDISET(MUTYPE,NPAR+NLOC,0)
         CALL XDISET(VALI,NPAR,0)
         CALL XDRSET(VALR(1,1),NPAR+NLOC,0.0)
         CALL XDRSET(VALR(1,2),NPAR+NLOC,0.0)
         DO 30 I=1,NPAR
   30    VALH(I)=' '
         CALL XDLSET(LCUB2,NPAR+NLOC,LCUBIC)
         CALL REDGET(INDIC,IBM,FLOTT,TEXT12,DFLOTT)
         IF(INDIC.NE.1) CALL XABORT('NCRDRV: INTEGER DATA EXPECTED.')
         IF(IBM.GT.NMIX) CALL XABORT('NCRDRV: NMIX OVERFLOW.')
         IBMOLD=1
         CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
         IF(INDIC.NE.3) CALL XABORT('NCRDRV: CHARACTER DATA EXPECTED.')
         IF(TEXT12.EQ.'FROM') THEN
            CALL REDGET(INDIC,IBMOLD,FLOTT,TEXT12,DFLOTT)
            IF(INDIC.NE.1) CALL XABORT('NCRDRV: INTEGER DATA EXPECTED.')
            MIXC(IBM)=IBMOLD
            GO TO 10
         ELSE IF(TEXT12.EQ.'USE') THEN
            MIXC(IBM)=IBM
            GO TO 10
         ENDIF
         MIXC(IBM)=IBMOLD
         GO TO 20
      ELSE IF(TEXT12.EQ.'MICRO') THEN
         IF(IBM.EQ.0) CALL XABORT('NCRDRV: MIX NOT SET (1).')
         CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
         IF(INDIC.NE.3) CALL XABORT('NCRDRV: CHARACTER DATA EXPECTED.')
         IF(TEXT12.EQ.'ALL') THEN
            LISO(IBM)=.TRUE.
         ELSE IF(TEXT12.EQ.'ONLY') THEN
            LISO(IBM)=.FALSE.
         ENDIF
         CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
         IF(INDIC.NE.3) CALL XABORT('NCRDRV: CHARACTER DATA EXPECTED.')
   40    IF(TEXT12.EQ.'ENDMIX') THEN
            GO TO 20
         ELSE
            NISO(IBM)=NISO(IBM)+1
            IF(NISO(IBM).GT.MAXISD) CALL XABORT('NCRDRV: MAXISD OVERFL'
     1      //'OW.')
            MAXNIS=MAX(MAXNIS,NISO(IBM))
            READ(TEXT12,'(2A4)') (HISO(I0,IBM,NISO(IBM)),I0=1,2)
            CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
            IF(INDIC.EQ.2) THEN
               CONC(IBM,NISO(IBM))=FLOTT
            ELSE IF((INDIC.EQ.3).AND.(TEXT12.EQ.'*')) THEN
               CONC(IBM,NISO(IBM))=-99.99
            ELSE
               CALL XABORT('NCRDRV: INVALID HISO DATA.')
            ENDIF
            CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
            IF(INDIC.NE.3) CALL XABORT('NCRDRV: CHARACTER DATA EXPECTE'
     1      //'D.')
            GO TO 40
         ENDIF
      ELSE IF((TEXT12.EQ.'SET').OR.(TEXT12.EQ.'DELTA')) THEN
         IF(IBM.EQ.0) CALL XABORT('NCRDRV: MIX NOT SET (2).')
         ITYPE=0
         IF(TEXT12.EQ.'SET') THEN
            ITYPE=1
         ELSE IF(TEXT12.EQ.'DELTA') THEN
            ITYPE=2
            LDELTA(IBM)=.TRUE.
         ENDIF
         CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
         IF(INDIC.NE.3) CALL XABORT('NCRDRV: CHARACTER DATA EXPECTED.')
         IF((TEXT12.EQ.'LINEAR').OR.(TEXT12.EQ.'CUBIC')) THEN
            HCUBIC=TEXT12
            CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
         ELSE
            HCUBIC=' '
         ENDIF
         IF(INDIC.NE.3) CALL XABORT('NCRDRV: CHARACTER DATA EXPECTED.')
         DO 50 I=1,NPAR
         IF(TEXT12.EQ.PARKEY(I)) THEN
            IPAR=I
            GO TO 60
         ENDIF
   50    CONTINUE
         GO TO 100
   60    IF(HCUBIC.EQ.'LINEAR') THEN
            LCUB2(IPAR)=.FALSE.
         ELSE IF(HCUBIC.EQ.'CUBIC') THEN
            LCUB2(IPAR)=.TRUE.
         ENDIF
         LPCPO=LCMGID(IPCPO,'GLOBAL')
         CALL LCMGET(LPCPO,'NVALUE',NVALUE)
         IF(NVALUE(IPAR).GT.MAXVAL) CALL XABORT('NCRDRV: MAXVAL OVERFL'
     1   //'OW.')
         WRITE(RECNAM,'(''pval'',I8.8)') IPAR
         CALL LCMLEN(LPCPO,RECNAM,LENGTH,ITYLCM)
         IF(LENGTH.EQ.0) THEN
            WRITE(HSMG,'(25HNCRDRV: GLOBAL PARAMETER ,A,9H NOT SET.)')
     1      PARKEY(IPAR)
            CALL XABORT(HSMG)
         ENDIF
         IF(PARFMT(IPAR).EQ.'INTEGER') THEN
            IF(ITYPE.NE.1) CALL XABORT('NCRDRV: SET MANDATORY WITH INT'
     1      //'EGER PARAMETERS.')
            CALL REDGET(INDIC,VALI(IPAR),FLOTT,TEXT12,DFLOTT)
            IF(INDIC.NE.1) CALL XABORT('NCRDRV: INTEGER DATA EXPECTED.')
            CALL LCMGET(LPCPO,RECNAM,VINTE)
            IF(IMPX.GT.0) THEN
               WRITE(IOUT,'(13H NCRDRV: KEY=,A,18H TABULATED POINTS=,
     1         1P,6I12/(35X,6I12))') PARKEY(IPAR),(VINTE(I),I=1,
     2         NVALUE(IPAR))
            ENDIF
            DO 70 J=1,NVALUE(IPAR)
            IF(VALI(IPAR).EQ.VINTE(J)) THEN
               MUPLET(IPAR)=J
               MUTYPE(IPAR)=ITYPE
               GO TO 10
            ENDIF
   70       CONTINUE
            WRITE(HSMG,'(26HNCRDRV: INTEGER PARAMETER ,A,9H WITH VAL,
     1      2HUE,I5,29H NOT FOUND IN COMPO DATABASE.)') PARKEY(IPAR),
     2      VALI(IPAR)
            CALL XABORT(HSMG)
         ELSE IF(PARFMT(IPAR).EQ.'REAL') THEN
            CALL REDGET(INDIC,NITMA,VALR(IPAR,1),TEXT12,DFLOTT)
            IF(INDIC.NE.2) CALL XABORT('NCRDRV: REAL DATA EXPECTED.')
            VALR(IPAR,2)=VALR(IPAR,1)
            CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
            IF(INDIC.EQ.2) THEN
               VALR(IPAR,2)=FLOTT
               CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
            ENDIF
            CALL LCMGET(LPCPO,RECNAM,VREAL)
            IF(IMPX.GT.0) THEN
               WRITE(IOUT,'(13H NCRDRV: KEY=,A,18H TABULATED POINTS=,
     1         1P,6E12.4/(35X,6E12.4))') PARKEY(IPAR),(VREAL(I),I=1,
     2         NVALUE(IPAR))
               IF(LCUB2(IPAR)) THEN
                 WRITE(IOUT,'(31H NCRDRV: ->CUBIC INTERPOLATION.)')
               ELSE
                 WRITE(IOUT,'(32H NCRDRV: ->LINEAR INTERPOLATION.)')
               ENDIF
            ENDIF
            IF(VALR(IPAR,1).EQ.VALR(IPAR,2)) THEN
               DO 80 J=1,NVALUE(IPAR)
               IF(ABS(VALR(IPAR,1)-VREAL(J)).LE.REPS*ABS(VREAL(J))) THEN
                  MUPLET(IPAR)=J
                  IF(ITYPE.NE.1) MUPLET(IPAR)=-1
                  MUTYPE(IPAR)=ITYPE
                  GO TO 20
               ENDIF
   80          CONTINUE
            ENDIF
            IF(VALR(IPAR,1).LT.VREAL(1)) THEN
               WRITE(HSMG,'(23HNCRDRV: REAL PARAMETER ,A,10H WITH VALU,
     1         1HE,1P,E12.4,25H IS OUTSIDE THE DOMAIN (<,E12.4,1H))')
     2         PARKEY(IPAR),VALR(IPAR,1),VREAL(1)
               CALL XABORT(HSMG)
            ELSE IF(VALR(IPAR,2).GT.VREAL(NVALUE(IPAR))) THEN
               WRITE(HSMG,'(23HNCRDRV: REAL PARAMETER ,A,10H WITH VALU,
     1         1HE,1P,E12.4,25H IS OUTSIDE THE DOMAIN (>,E12.4,1H))')
     2         PARKEY(IPAR),VALR(IPAR,1),VREAL(NVALUE(IPAR))
               CALL XABORT(HSMG)
            ELSE IF(VALR(IPAR,1).GT.VALR(IPAR,2)) THEN
               WRITE(HSMG,'(23HNCRDRV: REAL PARAMETER ,A,9H IS DEFIN,
     1         7HED WITH,1P,E12.4,2H >,E12.4,1H.)') PARKEY(IPAR),
     2         VALR(IPAR,1),VALR(IPAR,2)
               CALL XABORT(HSMG)
            ENDIF
            MUPLET(IPAR)=-1
            MUTYPE(IPAR)=ITYPE
            GO TO 20
         ELSE IF(PARFMT(IPAR).EQ.'STRING') THEN
            IF(ITYPE.NE.1) CALL XABORT('NCRDRV: SET MANDATORY WITH STR'
     1      //'ING PARAMETERS.')
            CALL REDGET(INDIC,NITMA,FLOTT,VALH(IPAR),DFLOTT)
            IF(INDIC.NE.3) CALL XABORT('NCRDRV: STRING DATA EXPECTED.')
            CALL LCMGTC(LPCPO,RECNAM,12,NVALUE(IPAR),VCHAR)
            IF(IMPX.GT.0) THEN
               WRITE(IOUT,'(13H NCRDRV: KEY=,A,18H TABULATED POINTS=,
     1         1P,6A12/(35X,6A12))') PARKEY(IPAR),(VCHAR(I),I=1,
     2         NVALUE(IPAR))
            ENDIF
            DO 90 J=1,NVALUE(IPAR)
            IF(VALH(IPAR).EQ.VCHAR(J)) THEN
               MUPLET(IPAR)=J
               MUTYPE(IPAR)=ITYPE
               GO TO 10
            ENDIF
   90       CONTINUE
            WRITE(HSMG,'(25HNCRDRV: STRING PARAMETER ,A,10H WITH VALU,
     1      2HE ,A12,29H NOT FOUND IN COMPO DATABASE.)') PARKEY(IPAR),
     2      VALH(IPAR)
            CALL XABORT(HSMG)
         ENDIF
  100    DO 110 I=1,NLOC
         IF(TEXT12.EQ.PARKEL(I)) THEN
            IPAR=NPAR+I
            GO TO 120
         ENDIF
  110    CONTINUE
         CALL XABORT('NCRDRV: PARAMETER '//TEXT12//' NOT FOUND.')
  120    LCUB2(IPAR)=LCUBIC
         JPCPO=LCMGID(IPCPO,'MIXTURES')
         KPCPO=LCMGIL(JPCPO,IBMOLD)
         LPCPO=LCMGID(KPCPO,'TREE')
         CALL LCMGET(LPCPO,'NVALUE',NVALUE)
         CALL REDGET(INDIC,NITMA,VALR(IPAR,1),TEXT12,DFLOTT)
         IF(INDIC.NE.2) CALL XABORT('NCRDRV: REAL DATA EXPECTED.')
         VALR(IPAR,2)=VALR(IPAR,1)
         CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
         IF(INDIC.EQ.2) THEN
            VALR(IPAR,2)=FLOTT
            CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
         ENDIF
         WRITE(RECNAM,'(''pval'',I8.8)') IPAR-NPAR
         CALL LCMLEN(LPCPO,RECNAM,LENGTH,ITYLCM)
         IF(LENGTH.EQ.0) THEN
            WRITE(HSMG,'(24HNCRDRV: LOCAL PARAMETER ,A,9H NOT SET.)')
     1      PARKEL(IPAR-NPAR)
            CALL XABORT(HSMG)
         ELSE IF(LENGTH.GT.MAXVAL) THEN
            CALL XABORT('NCRDRV: MAXVAL OVERFLOW.')
         ENDIF
         CALL LCMGET(LPCPO,RECNAM,VREAL)
         IF(IMPX.GT.0) THEN
            WRITE(IOUT,'(13H NCRDRV: KEY=,A,18H TABULATED POINTS=,
     1      1P,6E12.4/(35X,6E12.4))') PARKEL(IPAR-NPAR),(VREAL(I),I=1,
     2      NVALUE(IPAR-NPAR))
            IF(LCUB2(IPAR)) THEN
              WRITE(IOUT,'(31H NCRDRV: ->CUBIC INTERPOLATION.)')
            ELSE
              WRITE(IOUT,'(32H NCRDRV: ->LINEAR INTERPOLATION.)')
            ENDIF
         ENDIF
         IF(VALR(IPAR,1).EQ.VALR(IPAR,2)) THEN
            DO 130 J=1,NVALUE(IPAR-NPAR)
            IF(ABS(VALR(IPAR,1)-VREAL(J)).LE.REPS*ABS(VREAL(J))) THEN
               MUPLET(IPAR)=J
               IF(ITYPE.NE.1) MUPLET(IPAR)=-1
               MUTYPE(IPAR)=ITYPE
               GO TO 20
            ENDIF
  130       CONTINUE
         ENDIF
         IF(VALR(IPAR,1).LT.VREAL(1)) THEN
            WRITE(HSMG,'(23HNCRDRV: REAL PARAMETER ,A,11H WITH VALUE,
     1      1P,E12.4,23H IS OUTSIDE THE DOMAIN.)') PARKEL(IPAR-NPAR),
     2      VALR(IPAR,1)
            CALL XABORT(HSMG)
         ELSE IF(VALR(IPAR,2).GT.VREAL(NVALUE(IPAR-NPAR))) THEN
            WRITE(HSMG,'(23HNCRDRV: REAL PARAMETER ,A,11H WITH VALUE,
     1      1P,E12.4,23H IS OUTSIDE THE DOMAIN.)') PARKEL(IPAR-NPAR),
     2      VALR(IPAR,2)
            CALL XABORT(HSMG)
         ELSE IF(VALR(IPAR,1).GT.VALR(IPAR,2)) THEN
            WRITE(HSMG,'(23HNCRDRV: REAL PARAMETER ,A,9H IS DEFIN,
     1      7HED WITH,1P,E12.4,2H >,E12.4,1H.)') PARKEL(IPAR-NPAR),
     2      VALR(IPAR,1),VALR(IPAR,2)
            CALL XABORT(HSMG)
         ENDIF
         MUPLET(IPAR)=-1
         MUTYPE(IPAR)=ITYPE
         GO TO 20
      ELSE IF(TEXT12.EQ.'ENDMIX') THEN
*----
*  COMPUTE THE TERP FACTORS USING TABLE-OF-CONTENT INFORMATION.
*----
         IF(IBMOLD.GT.NMIL) CALL XABORT('NCRDRV: MIX OVERFLOW (COMPO).')
         IF(IBM.GT.NMIX) CALL XABORT('NCRDRV: MIX OVERFLOW (MICROLIB).')
         IF(NCAL.EQ.1) THEN
           TERP(1,IBM)=1.0
         ELSE
           CALL NCRTRP(IPCPO,LCUB2,IMPX,IBMOLD,NPAR,NLOC,NCAL,MUPLET,
     1     MUTYPE,VALR,0.0,TERP(1,IBM))
         ENDIF
         IBM=0
      ELSE IF((TEXT12.EQ.'COMPO').OR.(TEXT12.EQ.'TABLE').OR.
     1   (TEXT12.EQ.';')) THEN
*----
*  CHECK TERP FACTORS AND RETURN
*----
         IF(TEXT12.EQ.';') ITER=0
         IF(TEXT12.EQ.'COMPO') ITER=1
         IF(TEXT12.EQ.'TABLE') ITER=2
         DO 150 IBM=1,NMIX
         IBMOLD=MIXC(IBM)
         IF(IBMOLD.EQ.0) GO TO 150
         IF(NISO(IBM).GT.MAXNIS) CALL XABORT('NCRDRV: MAXNIS OVERFLOW.')
         IF(LDELTA(IBM)) THEN
            SUM=0.0
         ELSE
            SUM=1.0
         ENDIF
         DO 140 ICAL=1,NCAL
  140    SUM=SUM-TERP(ICAL,IBM)
         IF(ABS(SUM).GT.1.0E-4) THEN
            WRITE(HSMG,'(43HNCRDRV: INVALID INTERPOLATION FACTORS IN MI,
     1      5HXTURE,I4,1H.)') IBM
            CALL XABORT(HSMG)
         ENDIF
  150    CONTINUE
         GO TO 160
      ELSE
         CALL XABORT('NCRDRV: '//TEXT12//' IS AN INVALID KEYWORD.')
      ENDIF
      GO TO 10
*----
*  SCRATCH STORAGE DEALLOCATION
*----
  160 DEALLOCATE(LDELTA)
      RETURN
      END
