summaryrefslogtreecommitdiff
path: root/Dragon/src/SAPCAT.f
diff options
context:
space:
mode:
Diffstat (limited to 'Dragon/src/SAPCAT.f')
-rw-r--r--Dragon/src/SAPCAT.f295
1 files changed, 295 insertions, 0 deletions
diff --git a/Dragon/src/SAPCAT.f b/Dragon/src/SAPCAT.f
new file mode 100644
index 0000000..26da358
--- /dev/null
+++ b/Dragon/src/SAPCAT.f
@@ -0,0 +1,295 @@
+*DECK SAPCAT
+ SUBROUTINE SAPCAT(IPSAP,IPRHS,NORIG,NPARN,MUPCPO,LGNCPO,LWARN)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* To catenate a RHS saphyb into the output saphyb.
+*
+*Copyright:
+* Copyright (C) 2008 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
+* IPSAP pointer to the output saphyb.
+* IPRHS pointer to the rhs saphyb (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 saphyb.
+* MUPCPO tuple of the new global parameters in the output saphyb.
+* LGNCPO LGNEW value of the new global parameters in the output
+* saphyb.
+* LWARN logical used in case if an elementary calculation in the RHS
+* is already present in saphyb. If LWARN=.true. a warning is
+* send and the saphyb values are kept otherwise XABORT is
+* called (default).
+*
+*-----------------------------------------------------------------------
+*
+ USE GANLIB
+*----
+* SUBROUTINE ARGUMENTS
+*----
+ TYPE(C_PTR) IPSAP,IPRHS
+ INTEGER NORIG,NPARN,MUPCPO(NPARN)
+ LOGICAL LGNCPO(NPARN),LWARN
+*----
+* LOCAL VARIABLES
+*----
+ PARAMETER (NDIMSA=50,MAXPAR=50,MAXVAL=1000)
+ INTEGER IDATA(NDIMSA),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)*4,PARCPO(MAXPAR)*4,DIRNAM*12
+ LOGICAL COMTRE,LGERR,LGNEW(MAXPAR)
+*----
+* ALLOCATABLE ARRAYS
+*----
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: IORRHS,JDEBAR,JARBVA,VINTE,
+ 1 IDEBAR,IARBVA,IORIGI
+ REAL, ALLOCATABLE, DIMENSION(:) :: VREAL
+*
+ CALL LCMGET(IPRHS,'DIMSAP',IDATA)
+ NMIL=IDATA(7)
+ NPAR=IDATA(8)
+ NLOC=IDATA(11)
+ NVPR=IDATA(17) ! number of nodes in RHS
+ NCALR=IDATA(19) ! number of calculations in RHS
+ NG=IDATA(20)
+ IF(NCALR.EQ.0) CALL XABORT('SAPCAT: NO CALCULATION IN RHS SAPHYB'
+ 1 //'.')
+*
+ CALL LCMGET(IPSAP,'DIMSAP',IDATA)
+ NVPO=IDATA(17) ! initial number of nodes in LHS SAPHYB
+ NCAL=IDATA(19) ! initial number of calculations in LHS SAPHYB
+ IF(NPARN.GT.MAXPAR) CALL XABORT('SAPCAT: MAXPAR OVERFLOW.')
+ IF(NCAL.EQ.0) THEN
+* COMPLETE STATE-VECTOR.
+ IF(IDATA(7).EQ.0) THEN
+ IDATA(7)=NMIL
+ ELSE IF(NMIL.NE.IDATA(7)) THEN
+ WRITE(HSMG,'(42HSAPCAT: ELEMENTARY CALCULATION WITH AN INV,
+ 1 22HALIB NB. OF MIXTURES =,I7,3H NE,I7,1H.)') NMIL,IDATA(7)
+ CALL XABORT(HSMG)
+ ENDIF
+ IDATA(20)=NG
+ ELSE
+ IF(NMIL.NE.IDATA(7)) THEN
+ WRITE(HSMG,'(42HSAPCAT: ELEMENTARY CALCULATION WITH AN INV,
+ 1 22HALIB NB. OF MIXTURES =,I7,3H NE,I7,1H.)') NMIL,IDATA(7)
+ CALL XABORT(HSMG)
+ ELSE IF(NG.NE.IDATA(20)) THEN
+ WRITE(HSMG,'(42HSAPCAT: ELEMENTARY CALCULATION WITH AN INV,
+ 1 20HALIB NB. OF GROUPS =,I7,3H NE,I7,1H.)') NG,IDATA(20)
+ CALL XABORT(HSMG)
+ ENDIF
+ ENDIF
+ IF(NPAR.GT.NPARN) THEN
+ WRITE(HSMG,'(42HSAPCAT: 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.IDATA(11)) THEN
+ WRITE(HSMG,'(42HSAPCAT: ELEMENTARY CALCULATION WITH AN INV,
+ 1 30HALIB NB. OF LOCAL PARAMETERS =,I7,3H NE,I7,1H.)') NLOC,
+ 2 IDATA(11)
+ CALL XABORT(HSMG)
+ ENDIF
+*----
+* ADJUST THE SIZE OF THE OUTPUT SAPHYB AND UPDATE THE STATE-VECTOR
+*----
+ IDATA(19)=IDATA(19)+NCALR
+ CALL LCMPUT(IPSAP,'DIMSAP',NDIMSA,1,IDATA)
+*----
+* MAIN LOOP OVER THE NCALR ELEMENTARY CALCULATIONS OF THE RHS SAPHYB
+*----
+ NIDEM=0
+ NCALS=NCAL
+ DO 170 ICAL=1,NCALR
+*----
+* COMPUTE THE MUPLET VECTOR FROM THE RHS SAPHYB
+*----
+ CALL LCMSIX(IPRHS,'paramarbre',1)
+ CALL LCMLEN(IPRHS,'ARBVAL',MAXNVP,ITYLCM)
+ CALL LCMLEN(IPRHS,'ORIGIN',MAXNCA,ITYLCM)
+ ALLOCATE(IORRHS(MAXNCA))
+ CALL LCMGET(IPRHS,'ORIGIN',IORRHS)
+ ALLOCATE(JDEBAR(MAXNVP+1),JARBVA(MAXNVP))
+ CALL LCMGET(IPRHS,'DEBARB',JDEBAR)
+ CALL LCMGET(IPRHS,'ARBVAL',JARBVA)
+ CALL LCMSIX(IPRHS,' ',2)
+ DO 30 I=NVPR-NCALR+1,NVPR
+ IF(JDEBAR(I+1).EQ.ICAL) THEN
+ I0=I
+ GO TO 40
+ ENDIF
+ 30 CONTINUE
+ CALL XABORT('SAPCAT: MUPLET ALGORITHM FAILURE 1.')
+ 40 MUPRHS(NPAR)=JARBVA(I0)
+ DO 65 IPAR=NPAR-1,1,-1
+ DO 50 I=1,NVPR-NCALR
+ IF(JDEBAR(I+1).GT.I0) THEN
+ I0=I
+ GO TO 60
+ ENDIF
+ 50 ENDDO
+ CALL XABORT('SAPCAT: MUPLET ALGORITHM FAILURE 2.')
+ 60 MUPRHS(IPAR)=JARBVA(I0)
+ 65 CONTINUE
+ DEALLOCATE(JARBVA,JDEBAR)
+*----
+* RECOVER THE GLOBAL PARAMETERS
+*----
+ DO 70 I=1,NPARN
+ MUPLET(I)=MUPCPO(I)
+ LGNEW(I)=LGNCPO(I)
+ 70 CONTINUE
+ CALL LCMSIX(IPSAP,'paramdescrip',1)
+ CALL LCMGTC(IPSAP,'PARKEY',4,NPARN,PARCPO)
+ CALL LCMSIX(IPSAP,' ',2)
+ CALL LCMSIX(IPRHS,'paramdescrip',1)
+ CALL LCMGTC(IPRHS,'PARKEY',4,NPAR,PARKEY)
+ CALL LCMGTC(IPRHS,'PARFMT',8,NPAR,PARFMT)
+ CALL LCMGET(IPRHS,'NVALUE',NVALUE)
+ CALL LCMSIX(IPRHS,' ',2)
+ 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('SAPCAT: UNABLE TO FIND '//PARKEY(IPAR)//'.')
+ 90 WRITE(RECNAM,'(''pval'',I8)') IPAR
+ IVAL=MUPRHS(IPAR)
+ CALL LCMSIX(IPRHS,'paramvaleurs',1)
+ IF(PARFMT(IPAR).EQ.'FLOTTANT') THEN
+ ALLOCATE(VREAL(NVALUE(IPAR)))
+ CALL LCMGET(IPRHS,RECNAM,VREAL)
+ FLOTT=VREAL(IVAL)
+ DEALLOCATE(VREAL)
+ ELSE IF(PARFMT(IPAR).EQ.'ENTIER') THEN
+ ALLOCATE(VINTE(NVALUE(IPAR)))
+ CALL LCMGET(IPRHS,RECNAM,VINTE)
+ NITMA=VINTE(IVAL)
+ DEALLOCATE(VINTE)
+ ELSE IF(PARFMT(IPAR).EQ.'CHAINE') THEN
+ IF(NVALUE(IPAR).GT.MAXVAL) CALL XABORT('SAPCAT: MAXVAL OVE'
+ 1 //'RFLOW.')
+ CALL LCMGTC(IPRHS,RECNAM,12,NVALUE(IPAR),VCHAR)
+ TEXT12=VCHAR(IVAL)
+ ENDIF
+ CALL LCMSIX(IPRHS,' ',2)
+ CALL SAPPAV(IPSAP,IPARN,NPARN,PARFMT(IPAR),FLOTT,NITMA,TEXT12,
+ 1 MUPLET(IPARN),LGNEW(IPARN))
+ 100 CONTINUE
+*----
+* UPDATE THE PARAMETER TREE IN THE OUTPUT SAPHYB
+*----
+ CALL LCMSIX(IPSAP,'paramarbre',1)
+ CALL LCMLEN(IPSAP,'ARBVAL',ILONG,ITYLCM)
+ IF(ILONG.EQ.0) THEN
+ MAXNVP=20*(NPARN+1)
+ ALLOCATE(IDEBAR(MAXNVP+1),IARBVA(MAXNVP))
+ IDEBAR(:MAXNVP+1)=0
+ IARBVA(:MAXNVP)=0
+ IARBVA=0
+ DO 140 I=1,NPARN
+ IDEBAR(I)=I+1
+ IARBVA(I+1)=1
+ 140 CONTINUE
+ IDEBAR(NPARN+1)=NPARN+2
+ IDEBAR(NPARN+2)=1
+ NCALS=1
+ NVPNEW=NPARN+1
+ ELSE
+ CALL LCMLEN(IPSAP,'ARBVAL',JLONG,ITYLCM)
+ ALLOCATE(JDEBAR(JLONG+1),JARBVA(JLONG))
+ CALL LCMGET(IPSAP,'DEBARB',JDEBAR)
+ CALL LCMGET(IPSAP,'ARBVAL',JARBVA)
+ DO 150 IPAR=1,NPARN
+ IF(LGNEW(IPAR)) THEN
+ II=IPAR
+ GO TO 160
+ ENDIF
+ 150 CONTINUE
+ II=NPARN+1
+ 160 LGERR=COMTRE(NPARN,NVPO,JARBVA,JDEBAR,MUPLET,KK,I0,IORD,JJ,
+ 1 LAST)
+ IF((II.GT.NPARN).AND.LGERR) THEN
+ WRITE(TEXT4,'(I4)') IORD
+ IF(LWARN) THEN
+ WRITE(6,*)'SAPCAT: ELEMENTARY CALCULATION HAS THE ',
+ 1 'SAME PARAMETERS AS ELEMENTARY CALCULATION NB ',TEXT4
+ DEALLOCATE(JARBVA,JDEBAR,IORRHS)
+ CALL LCMSIX(IPSAP,' ',2)
+ NIDEM=NIDEM+1
+ GOTO 170
+ ELSE
+ CALL XABORT('SAPCAT: ELEMENTARY CALCULATION HAS THE '//
+ 1 'SAME PARAMETERS AS ELEMENTARY CALCULATION NB '//TEXT4)
+ ENDIF
+ ENDIF
+*
+* Size of the new tree.
+*
+ NVPNEW=NVPO+NPARN+1-MIN(II,KK)
+ IF(NVPNEW.GT.MAXNVP) MAXNVP=NVPNEW+MAXNVP
+ ALLOCATE(IDEBAR(MAXNVP+1),IARBVA(MAXNVP))
+ IDEBAR(NVPNEW+2:MAXNVP+1)=0
+ IARBVA(NVPNEW+1:MAXNVP)=0
+*
+* Update values and suppress old PARBRE.
+*
+ CALL COMARB(NPARN,NVPO,NVPNEW,JDEBAR,JARBVA,LGNEW,MUPLET,
+ 1 NCALS,IDEBAR,IARBVA)
+ DEALLOCATE(JARBVA,JDEBAR)
+ ENDIF
+ IF(NCALS.NE.NCAL+ICAL-NIDEM) CALL XABORT('SAPCAT: INVALID NCALS.')
+ NVPO=NVPNEW
+ CALL LCMPUT(IPSAP,'NCALS',1,1,NCALS)
+ CALL LCMPUT(IPSAP,'DEBARB',NVPNEW+1,1,IDEBAR)
+ CALL LCMPUT(IPSAP,'ARBVAL',NVPNEW,1,IARBVA)
+ DEALLOCATE(IARBVA,IDEBAR)
+ IF(NCALS.EQ.1) THEN
+ MAXNCA=1000
+ ALLOCATE(IORIGI(MAXNCA))
+ IORIGI(:MAXNCA)=0
+ ELSE
+ CALL LCMLEN(IPSAP,'ORIGIN',MAXNCA,ITYLCM)
+ IF(NCALS.GT.MAXNCA) MAXNCA=NCALS+MAXNCA
+ ALLOCATE(IORIGI(MAXNCA))
+ IORIGI(:MAXNCA)=0
+ CALL LCMGET(IPSAP,'ORIGIN',IORIGI)
+ ENDIF
+ IF(IORRHS(ICAL).EQ.0) THEN
+ IORIGI(NCALS)=NORIG
+ ELSE
+ IORIGI(NCALS)=NCAL+IORRHS(ICAL)
+ ENDIF
+ CALL LCMPUT(IPSAP,'ORIGIN',NCALS,1,IORIGI)
+ DEALLOCATE(IORIGI)
+ CALL LCMSIX(IPSAP,' ',2)
+ DEALLOCATE(IORRHS)
+*----
+* RECOVER THE ELEMENTARY CALCULATION
+*----
+ WRITE(DIRNAM,'(''calc'',I8)') NCAL+ICAL-NIDEM
+ CALL LCMSIX(IPSAP,DIRNAM,1)
+ WRITE(DIRNAM,'(''calc'',I8)') ICAL
+ CALL LCMSIX(IPRHS,DIRNAM,1)
+ CALL LCMEQU(IPRHS,IPSAP)
+ CALL LCMSIX(IPRHS,' ',2)
+ CALL LCMSIX(IPSAP,' ',2)
+ 170 CONTINUE
+* END OF LOOP ON ELEMENTARY CALCULATIONS. ********************
+ IDATA(17)=NVPO
+ IDATA(19)=NCALS
+ CALL LCMPUT(IPSAP,'DIMSAP',NDIMSA,1,IDATA)
+ RETURN
+ END
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 13:17:46 +0000