*DECK COMCAT
      SUBROUTINE COMCAT(IPCPO,IPRHS,NORIG,NPARN,MUPCPO,LGNCPO,LWARN)
*
*-----------------------------------------------------------------------
*
*Purpose:
* catenate a RHS compo into the output multicompo.
*
*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
* IPCPO   pointer to the output multicompo.
* IPRHS   pointer to the rhs multicompo (contains the new calculations).
* NORIG   index of the elementary calculation associated to the
*         father node in the parameter tree.
* NPARN   number of global parameters in the output multicompo.
* MUPCPO  tuple of the new global parameters in the output multicompo.
* LGNCPO  LGNEW value of the new global parameters in the output
*         multicompo.
* LWARN   logical used in case if an elementary calculation in the RHS 
*         is already present in CPO. If LWARN=.true. a warning is send 
*         and the CPO values are kept, otherwise XABORT is called
*         (default).
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) IPCPO,IPRHS
      INTEGER NORIG,NPARN,MUPCPO(NPARN)
      LOGICAL LGNCPO(NPARN),LWARN
*----
*  LOCAL VARIABLES
*----
      TYPE(C_PTR) JPCPO,KPCPO,JPRHS,KPRHS,LPCPO,LPRHS,MPCPO,MPRHS
      PARAMETER (NSTATE=40,MAXPAR=50,MAXVAL=1000)
      INTEGER ISTATE(NSTATE),NVPO(2),NVALUE(2*MAXPAR),MUPLET(2*MAXPAR),
     1 MUPRHS(2*MAXPAR)
      CHARACTER HSMG*131,RECNAM*12,TEXT4*4,TEXT12*12,PARFMT(MAXPAR)*8,
     1 VCHAR(MAXVAL)*12,PARKEY(MAXPAR)*12,PARCPO(MAXPAR)*12
      LOGICAL COMTRE,LGERR,LGNEW(MAXPAR)
*----
*  ALLOCATABLE ARRAYS
*----
      INTEGER, ALLOCATABLE, DIMENSION(:) :: ILCALR,MUOLD,IORRHS,IDEBAR,
     1 IARBVA,JDEBAR,JARBVA,IORIGI,VINTE
      REAL, ALLOCATABLE, DIMENSION(:) :: VREAL
      LOGICAL, ALLOCATABLE, DIMENSION(:) :: LGOLD
*
      NIDEM=0
      CALL LCMGET(IPRHS,'STATE-VECTOR',ISTATE)
      NMIL=ISTATE(1)
      NG=ISTATE(2)
      NCALR=ISTATE(3)
      NPAR=ISTATE(5)
      NLOC=ISTATE(6)
      IF(NCALR.EQ.0) CALL XABORT('COMCAT: NO CALCULATION IN RHS COMPO.')
      ALLOCATE(ILCALR(NCALR))
*
      CALL LCMGET(IPCPO,'STATE-VECTOR',ISTATE)
      NCAL=ISTATE(3)
      IF(NPARN+NLOC.GT.2*MAXPAR) CALL XABORT('COMCAT: MAXPAR OVERFLOW.')
      IF(NCAL.EQ.0) THEN
*        COMPLETE STATE-VECTOR.
         IF(ISTATE(1).EQ.0) THEN
            ISTATE(1)=NMIL
         ELSE IF(NMIL.NE.ISTATE(1)) THEN
            WRITE(HSMG,'(42HCOMCAT: ELEMENTARY CALCULATION WITH AN INV,
     1      22HALIB NB. OF MIXTURES =,I7,3H NE,I7,1H.)') NMIL,ISTATE(1)
            CALL XABORT(HSMG)
         ENDIF
         ISTATE(2)=NG
      ELSE
         IF(NMIL.NE.ISTATE(1)) THEN
            WRITE(HSMG,'(42HCOMCAT: ELEMENTARY CALCULATION WITH AN INV,
     1      22HALIB NB. OF MIXTURES =,I7,3H NE,I7,1H.)') NMIL,ISTATE(1)
            CALL XABORT(HSMG)
         ELSE IF(NG.NE.ISTATE(2)) THEN
            WRITE(HSMG,'(42HCOMCAT: ELEMENTARY CALCULATION WITH AN INV,
     1      20HALIB NB. OF GROUPS =,I7,3H NE,I7,1H.)') NG,ISTATE(2)
            CALL XABORT(HSMG)
         ENDIF
      ENDIF
      IF(NPAR.GT.NPARN) THEN
         WRITE(HSMG,'(42HCOMCAT: ELEMENTARY CALCULATION WITH AN INV,
     1   31HALIB NB. OF GLOBAL PARAMETERS =,I7,3H NE,I7,1H.)') NPAR,
     2   NPARN
         CALL XABORT(HSMG)
      ELSE IF(NLOC.NE.ISTATE(6)) THEN
         WRITE(HSMG,'(42HCOMCAT: ELEMENTARY CALCULATION WITH AN INV,
     1   30HALIB NB. OF LOCAL PARAMETERS =,I7,3H NE,I7,1H.)') NLOC,
     2   ISTATE(6)
         CALL XABORT(HSMG)
      ENDIF
*----
*  ADJUST THE SIZE OF THE OUTPUT COMPO
*----
      ISTATE(3)=ISTATE(3)+NCALR
      IF(ISTATE(3).GT.ISTATE(4)) THEN
         ISTATE(4)=ISTATE(4)+NCALR+9
         JPCPO=LCMLID(IPCPO,'MIXTURES',NMIL)
         DO 10 IBM=1,NMIL
         KPCPO=LCMDIL(JPCPO,IBM)
         LPCPO=LCMLID(KPCPO,'CALCULATIONS',ISTATE(4))
   10    CONTINUE
      ENDIF
      MAXCAL=ISTATE(4)
*----
*  UPDATE THE STATE-VECTOR
*----
      CALL LCMPUT(IPCPO,'STATE-VECTOR',NSTATE,1,ISTATE)
*----
*  MAIN LOOP OVER THE HOMOGENEOUS MIXTURES *********************
*----
      JPCPO=LCMLID(IPCPO,'MIXTURES',NMIL)
      JPRHS=LCMGID(IPRHS,'MIXTURES')
      ALLOCATE(MUOLD(NCALR*NPARN),LGOLD(NCALR*NPARN))
      DO 190 IBM=1,NMIL
      KPCPO=LCMDIL(JPCPO,IBM)
      KPRHS=LCMGIL(JPRHS,IBM)
*----
*  MAIN LOOP OVER THE NCALR ELEMENTARY CALCULATIONS OF THE RHS COMPO
*----
      CALL XDISET(ILCALR,NCALR,1)
      NIDEM=0
      DO 170 ICAL=1,NCALR
*----
*  COMPUTE THE MUPLET VECTOR FROM THE RHS COMPO
*----
      CALL LCMSIX(KPRHS,'TREE',1)
      CALL LCMLEN(KPRHS,'ARBVAL',MAXNVP,ITYLCM)
      CALL LCMLEN(KPRHS,'ORIGIN',MAXNCA,ITYLCM)
      ALLOCATE(IORRHS(MAXNCA))
      CALL LCMGET(KPRHS,'ORIGIN',IORRHS)
      ALLOCATE(JDEBAR(MAXNVP+1),JARBVA(MAXNVP))
      CALL LCMGET(KPRHS,'NCALS',NCALS)
      CALL LCMGET(KPRHS,'DEBARB',JDEBAR)
      CALL LCMGET(KPRHS,'ARBVAL',JARBVA)
      CALL LCMGET(KPRHS,'NVP',NVPO)
      DO 30 I=NVPO(1)-NCALS+1,NVPO(1)
      IF(JDEBAR(I+1).EQ.ICAL) THEN
         I0=I
         GO TO 40
      ENDIF
   30 CONTINUE
      CALL XABORT('COMCAT: MUPLET ALGORITHM FAILURE 1.')
   40 MUPRHS(NPAR+NLOC)=JARBVA(I0)
      DO 60 IPAR=NPAR+NLOC-1,1,-1
      DO 50 I=1,NVPO(1)-NCALS
      IF(JDEBAR(I+1).GT.I0) THEN
         I0=I
         GO TO 60
      ENDIF
   50 ENDDO
      CALL XABORT('COMCAT: MUPLET ALGORITHM FAILURE 2.')
   60 MUPRHS(IPAR)=JARBVA(I0)
      DEALLOCATE(JARBVA,JDEBAR)
*----
*  RECOVER THE GLOBAL PARAMETERS
*----
      IF(IBM.EQ.1) THEN
         DO 70 I=1,NPARN
         MUPLET(I)=MUPCPO(I)
   70    LGNEW(I)=LGNCPO(I)
         CALL LCMSIX(IPCPO,'GLOBAL',1)
         CALL LCMSIX(IPRHS,'GLOBAL',1)
         CALL LCMGTC(IPCPO,'PARKEY',12,NPARN,PARCPO)
         CALL LCMGTC(IPRHS,'PARKEY',12,NPAR,PARKEY)
         CALL LCMGTC(IPRHS,'PARFMT',8,NPAR,PARFMT)
         CALL LCMGET(IPRHS,'NVALUE',NVALUE)
         DO 100 IPAR=1,NPAR
            DO 80 I0=1,NPARN
            IF(PARKEY(IPAR).EQ.PARCPO(I0)) THEN
               IPARN=I0
               GO TO 90
            ENDIF
   80       CONTINUE
            CALL XABORT('COMCAT: UNABLE TO FIND '//PARKEY(IPAR)//'.')
   90       WRITE(RECNAM,'(''pval'',I8.8)') IPAR
            IVAL=MUPRHS(IPAR)
            IF(PARFMT(IPAR).EQ.'REAL') THEN
               ALLOCATE(VREAL(NVALUE(IPAR)))
               CALL LCMGET(IPRHS,RECNAM,VREAL)
               FLOTT=VREAL(IVAL)
               DEALLOCATE(VREAL)
            ELSE IF(PARFMT(IPAR).EQ.'INTEGER') THEN
               ALLOCATE(VINTE(NVALUE(IPAR)))
               CALL LCMGET(IPRHS,RECNAM,VINTE)
               NITMA=VINTE(IVAL)
               DEALLOCATE(VINTE)
            ELSE IF(PARFMT(IPAR).EQ.'STRING') THEN
               IF(NVALUE(IPAR).GT.MAXVAL) CALL XABORT('COMCAT: MAXVAL '
     1         //'OVERFLOW.')
               CALL LCMGTC(IPRHS,RECNAM,12,NVALUE(IPAR),VCHAR)
               TEXT12=VCHAR(IVAL)
            ENDIF
            CALL COMPAV(IPCPO,IPARN,NPARN,PARFMT(IPAR),FLOTT,NITMA,
     1      TEXT12,MUPLET(IPARN),LGNEW(IPARN))
  100    CONTINUE
         DO 110 IPARN=1,NPARN
         MUOLD((ICAL-1)*NPARN+IPARN)=MUPLET(IPARN)
  110    LGOLD((ICAL-1)*NPARN+IPARN)=LGNEW(IPARN)
         CALL LCMSIX(IPRHS,' ',2)
         CALL LCMSIX(IPCPO,' ',2)
      ELSE
         DO 120 IPARN=1,NPARN
         MUPLET(IPARN)=MUOLD((ICAL-1)*NPARN+IPARN)
  120    LGNEW(IPARN)=LGOLD((ICAL-1)*NPARN+IPARN)
      ENDIF
*----
*  RECOVER THE LOCAL PARAMETERS
*----
      CALL LCMSIX(KPCPO,'TREE',1)
      DO 130 ILOC=1,NLOC
         WRITE(RECNAM,'(''pval'',I8.8)') ILOC
         IVAL=MUPRHS(NPAR+ILOC)
         CALL LCMLEN(KPRHS,RECNAM,ILONG,ITYLCM)
         ALLOCATE(VREAL(ILONG))
         CALL LCMGET(KPRHS,RECNAM,VREAL)
         FLOTT=VREAL(IVAL)
         DEALLOCATE(VREAL)
         CALL COMPAV(KPCPO,ILOC,NLOC,PARFMT(ILOC),FLOTT,NITMA,TEXT12,
     1   MUPLET(NPARN+ILOC),LGNEW(NPARN+ILOC))
  130 CONTINUE
      CALL LCMSIX(KPRHS,' ',2)
*----
*  UPDATE THE PARAMETER TREE IN THE OUTPUT COMPO
*----
      CALL LCMLEN(KPCPO,'NVP',ILONG,ITYLCM)
      IF(ILONG.EQ.0) THEN
         MAXNVP=20*(NPARN+NLOC+1)
         ALLOCATE(IDEBAR(MAXNVP+1),IARBVA(MAXNVP))
         CALL XDISET(IDEBAR,MAXNVP+1,0)
         CALL XDISET(IARBVA,MAXNVP,0)
         IARBVA=0
         DO 140 I=1,NPARN+NLOC
         IDEBAR(I)=I+1
  140    IARBVA(I+1)=1
         IDEBAR(NPARN+NLOC+1)=NPARN+NLOC+2
         IDEBAR(NPARN+NLOC+2)=1
         NCALS=1
         NVPNEW=NPARN+NLOC+1
      ELSE
         CALL LCMLEN(KPCPO,'ARBVAL',JLONG,ITYLCM)
         ALLOCATE(JDEBAR(JLONG+1),JARBVA(JLONG))
         CALL LCMGET(KPCPO,'NCALS',NCALS)
         CALL LCMGET(KPCPO,'DEBARB',JDEBAR)
         CALL LCMGET(KPCPO,'ARBVAL',JARBVA)
         CALL LCMGET(KPCPO,'NVP',NVPO)
         DO 150 IPAR=1,NPARN+NLOC
         IF(LGNEW(IPAR)) THEN
            II=IPAR
            GO TO 160
         ENDIF
  150    CONTINUE
         II=NPARN+NLOC+1
  160    LGERR=COMTRE(NPARN+NLOC,NVPO(1),JARBVA,JDEBAR,MUPLET,KK,I0,
     1   IORD,JJ,LAST)
         IF((II.GT.NPARN+NLOC).AND.LGERR) THEN
            WRITE(TEXT4,'(I4)') IORD
            IF(LWARN) THEN
               WRITE(6,*)'COMCAT: ELEMENTARY CALCULATION HAS THE ',
     1         'SAME PARAMETERS AS ELEMENTARY CALCULATION NB ',TEXT4
               DEALLOCATE(JARBVA,JDEBAR,IORRHS)
               CALL LCMSIX(KPCPO,' ',2)
               ILCALR(ICAL)=0
               NIDEM=NIDEM+1
               GOTO 170
            ELSE
               CALL XABORT('COMCAT: ELEMENTARY CALCULATION HAS THE '//
     1         'SAME PARAMETERS AS ELEMENTARY CALCULATION NB '//TEXT4)
            ENDIF
         ENDIF
*
*        Size of the new tree.
*
         NVPNEW=NVPO(1)+NPARN+NLOC+1-MIN(II,KK)
         IF(NVPNEW.GT.MAXNVP) MAXNVP=NVPNEW+MAXNVP
         ALLOCATE(IDEBAR(MAXNVP+1),IARBVA(MAXNVP))
         CALL XDISET(IDEBAR(NVPNEW+2),MAXNVP-NVPNEW,0)
         CALL XDISET(IARBVA(NVPNEW+1),MAXNVP-NVPNEW,0)
*
*        Update values and suppress old PARBRE.
*
         CALL COMARB(NPARN+NLOC,NVPO(1),NVPNEW,JDEBAR,JARBVA,LGNEW,
     1   MUPLET,NCALS,IDEBAR,IARBVA)
         DEALLOCATE(JARBVA,JDEBAR)
      ENDIF
      IF(NCALS.NE.NCAL+ICAL-NIDEM) CALL XABORT('COMCAT: INVALID NCALS.')
      NVPO(1)=NVPNEW
      NVPO(2)=MAXNVP
      CALL LCMPUT(KPCPO,'NVP',2,1,NVPO)
      CALL LCMPUT(KPCPO,'NCALS',1,1,NCALS)
      CALL LCMPUT(KPCPO,'DEBARB',NVPO(1)+1,1,IDEBAR)
      CALL LCMPUT(KPCPO,'ARBVAL',NVPO(1),1,IARBVA)
      DEALLOCATE(IARBVA,IDEBAR)
      IF(NCALS.EQ.1) THEN
         ALLOCATE(IORIGI(MAXCAL))
         CALL XDISET(IORIGI,MAXCAL,0)
      ELSE
         CALL LCMLEN(KPCPO,'ORIGIN',MAXOLD,ITYLCM)
         IF(MAXOLD.GT.MAXCAL) CALL XABORT('COMCAT: ORIGIN OVERFLOW(1).')
         ALLOCATE(IORIGI(MAXCAL))
         CALL XDISET(IORIGI,MAXCAL,0)
         CALL LCMGET(KPCPO,'ORIGIN',IORIGI)
      ENDIF
      IF(NCALS.GT.MAXCAL) CALL XABORT('COMCAT: ORIGIN OVERFLOW(2).')
      IF(IORRHS(ICAL).EQ.0) THEN
         IORIGI(NCALS)=NORIG
      ELSE
         IORIGI(NCALS)=NCAL+IORRHS(ICAL)
      ENDIF
      CALL LCMPUT(KPCPO,'ORIGIN',MAXCAL,1,IORIGI)
      DEALLOCATE(IORIGI)
      CALL LCMSIX(KPCPO,' ',2)
      DEALLOCATE(IORRHS)
  170 CONTINUE
* END OF LOOP ON MIXTURES. ***********************************
*----
*  RECOVER THE MICROLIBS
*----
      LPCPO=LCMLID(KPCPO,'CALCULATIONS',ISTATE(4))
      LPRHS=LCMGID(KPRHS,'CALCULATIONS')
      NIDEM=0
      DO 180 ICAL=1,NCALR
         IF(ILCALR(ICAL).EQ.1)THEN
            MPCPO=LCMDIL(LPCPO,NCAL+ICAL-NIDEM)
            MPRHS=LCMGIL(LPRHS,ICAL)
            CALL LCMEQU(MPRHS,MPCPO)
         ELSE
            NIDEM=NIDEM+1
         ENDIF
  180 CONTINUE
  190 CONTINUE
      DEALLOCATE(LGOLD,MUOLD)
*----
*  RECOVER THE DEPLETION CHAIN
*----
      CALL LCMLEN(IPRHS,'DEPL-CHAIN',ILONG,ITYLCM)
      IF(ILONG.EQ.-1) THEN
         CALL LCMSIX(IPCPO,'DEPL-CHAIN',1)
         CALL LCMSIX(IPRHS,'DEPL-CHAIN',1)
         CALL LCMEQU(IPRHS,IPCPO)
         CALL LCMSIX(IPRHS,' ',2)
         CALL LCMSIX(IPCPO,' ',2)
      ENDIF
*----
*  RECOVER THE MACRO-GEOMETRIES
*----
      CALL LCMLEN(IPRHS,'GEOMETRIES',ILONG,ITYLCM)
      IF(ILONG.GT.0) THEN
         JPCPO=LCMLID(IPCPO,'GEOMETRIES',MAXCAL)
         JPRHS=LCMGID(IPRHS,'GEOMETRIES')
         DO 200 ICAL=1,NCALR
            IF(ILCALR(ICAL).EQ.1)THEN
            KPCPO=LCMDIL(JPCPO,NCAL+ICAL)
            KPRHS=LCMGIL(JPRHS,ICAL)
            CALL LCMEQU(KPRHS,KPCPO)
         ENDIF
  200    CONTINUE
         ISTATE(11)=1
      ENDIF
      DEALLOCATE(ILCALR)
      ISTATE(3)=ISTATE(3)-NIDEM
      CALL LCMPUT(IPCPO,'STATE-VECTOR',NSTATE,1,ISTATE)
* END OF LOOP ON ELEMENTARY CALCULATIONS. ********************
      RETURN
      END
