diff options
Diffstat (limited to 'Dragon/src/COMSDB.f')
| -rw-r--r-- | Dragon/src/COMSDB.f | 200 |
1 files changed, 200 insertions, 0 deletions
diff --git a/Dragon/src/COMSDB.f b/Dragon/src/COMSDB.f new file mode 100644 index 0000000..27e10f6 --- /dev/null +++ b/Dragon/src/COMSDB.f @@ -0,0 +1,200 @@ +*DECK COMSDB + SUBROUTINE COMSDB(IMPX,IPCPO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Show the structure of a multicompo file. +* +*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): R. Chambon +* +*Parameters: input +* IMPX print parameter. +* IPCPO pointer to the multicompo. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IMPX + TYPE(C_PTR) IPCPO +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40,MAXPAR=50,MAXVAL=1000) + TYPE(C_PTR) JPCPO,KPCPO + INTEGER ISTATE(NSTATE),NVPO(2),NVALUE(2*MAXPAR) + CHARACTER RECNAM*12,TEXT12*12,PARFMT(MAXPAR)*8, + 1 VCHAR(MAXVAL)*12,PARKEY(MAXPAR)*12,PARCPO(MAXPAR)*12 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MUPCPO,JDEBAR,JARBVA,VINTE + REAL, ALLOCATABLE, DIMENSION(:) :: VREAL +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(MUPCPO(2*MAXPAR)) +* + CALL LCMGET(IPCPO,'STATE-VECTOR',ISTATE) + NMIL=ISTATE(1) + NCAL=ISTATE(3) + MAXCAL=ISTATE(4) + NPAR=ISTATE(5) + NLOC=ISTATE(6) + IF(NPAR+NLOC.GT.2*MAXPAR) CALL XABORT('COMSDB: MAXPAR OVERFLOW.') + IF(NCAL.EQ.0) WRITE(6,*) 'The multi-compo DB is empty.' +*---- +* MAIN LOOP OVER THE HOMOGENEOUS MIXTURES ********************* +*---- + JPCPO=LCMGID(IPCPO,'MIXTURES') + DO 190 IBM=1,NMIL + KPCPO=LCMDIL(JPCPO,IBM) +*---- +* MAIN LOOP OVER THE NCALR ELEMENTARY CALCULATIONS OF THE COMPO +*---- + WRITE(6,*) 'LIST OF "MUPLET" included in the COMPO' + DO 170 ICAL=1,NCAL +*---- +* COMPUTE THE MUPLET VECTOR FROM THE COMPO +*---- + CALL LCMSIX(KPCPO,'TREE',1) + CALL LCMGET(KPCPO,'NVP',NVPO) + MAXNVP=NVPO(2) + ALLOCATE(JDEBAR(MAXNVP+1),JARBVA(MAXNVP)) + CALL LCMGET(KPCPO,'NCALS',NCALS) + CALL LCMGET(KPCPO,'DEBARB',JDEBAR) + CALL LCMGET(KPCPO,'ARBVAL',JARBVA) + I0=0 + 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('COMSDB: MUPLET ALGORITHM FAILURE 1.') + 40 MUPCPO(NPAR+NLOC)=JARBVA(I0) + DO 65 IPAR=NPAR+NLOC-1,1,-1 + I0=0 + DO 50 I=1,NVPO(1)-NCALS + IF(JDEBAR(I+1).GT.I0) THEN + I0=I + GO TO 60 + ENDIF + 50 CONTINUE + CALL XABORT('COMSDB: MUPLET ALGORITHM FAILURE 2.') + 60 MUPCPO(IPAR)=JARBVA(I0) + 65 CONTINUE + DEALLOCATE(JARBVA,JDEBAR) + CALL LCMSIX(KPCPO,' ',2) + WRITE(6,*)'ICAL #',ICAL,': ',(MUPCPO(JM),JM=1,NPAR+NLOC) + IF(IMPX.LE.1) GOTO 170 +*---- +* RECOVER THE GLOBAL PARAMETERS +*---- + CALL LCMSIX(IPCPO,'GLOBAL',1) + CALL LCMGTC(IPCPO,'PARKEY',12,NPAR,PARCPO) + CALL LCMGTC(IPCPO,'PARFMT',8,NPAR,PARFMT) + CALL LCMGET(IPCPO,'NVALUE',NVALUE) + DO 100 IPAR=1,NPAR + WRITE(RECNAM,'(''pval'',I8.8)') IPAR + IVAL=MUPCPO(IPAR) + IF(PARFMT(IPAR).EQ.'REAL') THEN + ALLOCATE(VREAL(NVALUE(IPAR))) + CALL LCMGET(IPCPO,RECNAM,VREAL) + FLOTT=VREAL(IVAL) + DEALLOCATE(VREAL) + write(6,*)'IPAR ',IPAR,'->',PARCPO(IPAR),FLOTT + ELSE IF(PARFMT(IPAR).EQ.'INTEGER') THEN + ALLOCATE(VINTE(NVALUE(IPAR))) + CALL LCMGET(IPCPO,RECNAM,VINTE) + NITMA=VINTE(IVAL) + DEALLOCATE(VINTE) + write(6,*)'IPAR ',IPAR,'->',PARCPO(IPAR),NITMA + ELSE IF(PARFMT(IPAR).EQ.'STRING') THEN + IF(NVALUE(IPAR).GT.MAXVAL) CALL XABORT('COMSDB: MAXVAL ' + 1 //'OVERFLOW.') + CALL LCMGTC(IPCPO,RECNAM,12,NVALUE(IPAR),VCHAR) + TEXT12=VCHAR(IVAL) + write(6,*)'IPAR ',IPAR,'->',PARCPO(IPAR),TEXT12 + ENDIF + 100 CONTINUE + CALL LCMSIX(IPCPO,' ',2) +*---- +* RECOVER THE LOCAL PARAMETERS +*---- + CALL LCMSIX(KPCPO,'TREE',1) + DO 130 ILOC=1,NLOC + WRITE(RECNAM,'(''pval'',I8.8)') ILOC + IVAL=MUPCPO(NPAR+ILOC) + CALL LCMLEN(KPCPO,RECNAM,ILONG,ITYLCM) + ALLOCATE(VREAL(ILONG)) + CALL LCMGET(KPCPO,RECNAM,VREAL) + FLOTT=VREAL(IVAL) + DEALLOCATE(VREAL) + WRITE(6,*)'ILOC ',ILOC,'->',PARKEY(IPAR),FLOTT + 130 CONTINUE + CALL LCMSIX(KPCPO,' ',2) + 170 CONTINUE +* END OF LOOP ON CALCULATIONS. ******************************* + IF (IMPX.EQ.0) GOTO 190 + WRITE(6,*) 'Summary of the parameter included in the COMPO' + CALL LCMSIX(IPCPO,'GLOBAL',1) + CALL LCMGTC(IPCPO,'PARKEY',12,NPAR,PARCPO) + CALL LCMGTC(IPCPO,'PARFMT',8,NPAR,PARFMT) + CALL LCMGET(IPCPO,'NVALUE',NVALUE) + DO 180 IPAR=1,NPAR + WRITE(RECNAM,'(''pval'',I8.8)') IPAR + IF(PARFMT(IPAR).EQ.'REAL') THEN + ALLOCATE(VREAL(NVALUE(IPAR))) + CALL LCMGET(IPCPO,RECNAM,VREAL) + WRITE(6,*)'IPAR ',IPAR,'->',PARKEY(IPAR), + 1 (VREAL(JM),JM=1,NVALUE(IPAR)) + DEALLOCATE(VREAL) + ELSE IF(PARFMT(IPAR).EQ.'INTEGER') THEN + ALLOCATE(VINTE(NVALUE(IPAR))) + CALL LCMGET(IPCPO,RECNAM,VINTE) + WRITE(6,*)'IPAR ',IPAR,'->',PARKEY(IPAR), + 1 (VINTE(JM),JM=1,NVALUE(IPAR)) + DEALLOCATE(VINTE) + ELSE IF(PARFMT(IPAR).EQ.'STRING') THEN + IF(NVALUE(IPAR).GT.MAXVAL) CALL XABORT('COMSDB: MAXVAL ' + 1 //'OVERFLOW.') + CALL LCMGTC(IPCPO,RECNAM,12,NVALUE(IPAR),VCHAR) + WRITE(6,*)'IPAR ',IPAR,'->',PARKEY(IPAR), + 1 (VCHAR(JM),JM=1,NVALUE(IPAR)) + ENDIF + 180 CONTINUE + CALL LCMSIX(IPCPO,' ',2) + CALL LCMSIX(KPCPO,'TREE',1) + DO 185 ILOC=1,NLOC + CALL LCMGTC(IPCPO,'PARKEL',12,NLOC,PARCPO) + CALL LCMGET(IPCPO,'NVALUE',NVALUE) + WRITE(RECNAM,'(''pval'',I8.8)') ILOC + CALL LCMLEN(KPCPO,RECNAM,ILONG,ITYLCM) + ALLOCATE(VREAL(ILONG)) + CALL LCMGET(KPCPO,RECNAM,VREAL) + WRITE(6,*)'ILOC ',ILOC,'->',PARCPO(ILOC), + 1 (VREAL(JM),JM=1,NVALUE(ILOC)) + DEALLOCATE(VREAL) + 185 CONTINUE + CALL LCMSIX(KPCPO,' ',2) + + 190 CONTINUE +* END OF LOOP ON MIXTURES. *********************************** +* +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(MUPCPO) + RETURN + END |