summaryrefslogtreecommitdiff
path: root/Dragon/src/EPC.f
diff options
context:
space:
mode:
Diffstat (limited to 'Dragon/src/EPC.f')
-rw-r--r--Dragon/src/EPC.f238
1 files changed, 238 insertions, 0 deletions
diff --git a/Dragon/src/EPC.f b/Dragon/src/EPC.f
new file mode 100644
index 0000000..55d865f
--- /dev/null
+++ b/Dragon/src/EPC.f
@@ -0,0 +1,238 @@
+*DECK EPC
+ SUBROUTINE EPC(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Process error propagation parameters.
+*
+*Copyright:
+* Copyright (C) 2009 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):
+* G. Marleau
+*
+*Parameters: input
+* NENTRY number of data structures transfered to this module.
+* HENTRY name of the data structures.
+* IENTRY data structure type where:
+* =1 for LCM memory object;
+* =2 for XSM file;
+* =3 for sequential binary file;
+* =4 for sequential ASCII file.
+* JENTRY access permission for the data structure where:
+* =0 for a data structure in creation mode;
+* =1 for a data structure in modifications mode;
+* =2 for a data structure in read-only mode.
+* KENTRY data structure pointer.
+*
+*Comments:
+* Instructions for the use of the EPC: module:
+* Param := EPC: [ Param ] [[ ParamDist ]] :: (EPCpara) (EPCget) ;
+* where
+* Param : parameter data structure.
+* ParamDist : sequential binary/ASCII parameter distributions
+* (EPCpara) : PARA keyword processing options (routine EPCPAR)
+* (EPCget) : GET keyword processing options (routine EPCGET)
+*
+*-----------------------------------------------------------------------
+*
+ USE GANLIB
+ IMPLICIT NONE
+*----
+* Subroutine arguments
+*----
+ INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY)
+ TYPE(C_PTR) KENTRY(NENTRY)
+ CHARACTER HENTRY(NENTRY)*12
+*----
+* Local parameters
+*----
+ INTEGER IOUT
+ CHARACTER NAMSBR*6
+ PARAMETER (IOUT=6,NAMSBR='EPC ')
+ INTEGER ILCMUP,ILCMDN,MXFIL,MXOPT
+ PARAMETER (ILCMUP=1,ILCMDN=2,MXFIL=20,MXOPT=20)
+ INTEGER NSTATE
+ PARAMETER (NSTATE=40)
+*----
+* Input and output parameters
+*----
+ INTEGER ITYPLU,INTLIR
+ CHARACTER CARLIR*12
+ REAL REALIR
+ DOUBLE PRECISION DBLLIR
+*----
+* Local variables
+*----
+ CHARACTER*12 CARRET,SENTRY(MXFIL),HET
+ INTEGER IEN
+ CHARACTER HSIGN*12
+ INTEGER IPRINT,NOPT,IOPT(MXOPT)
+ INTEGER ISTATE(NSTATE)
+*----
+* Validate entry parameters
+*----
+ IF(NENTRY .GT. MXFIL) CALL XABORT(NAMSBR//
+ > ': Too many files or data structures for this module.')
+*----
+* Scan data structure to determine signature (input or update)
+*----
+ DO IEN=1,NENTRY
+ SENTRY(IEN)=' '
+ IF(IENTRY(IEN) .EQ. 1 .OR. IENTRY(IEN) .EQ. 2) THEN
+ IF(JENTRY(IEN) .NE. 0) THEN
+ CALL LCMGTC(KENTRY(IEN),'SIGNATURE',12,HSIGN)
+ SENTRY(IEN)=HSIGN
+ ENDIF
+ ENDIF
+ ENDDO
+*----
+* Read EDIT and main option
+* Default option is NDIST option
+*----
+ CARRET=';'
+ NOPT=MXOPT
+ IOPT(:NOPT)=0
+ IPRINT=1
+ 100 CONTINUE
+ CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR)
+ IF(ITYPLU .EQ. 10) GO TO 105
+ IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR//
+ >': Read error -- Character variable expected')
+ CARRET=CARLIR
+ IF(CARLIR .EQ. ';') THEN
+ GO TO 105
+ ELSE IF(CARLIR .EQ. 'EDIT') THEN
+ CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR)
+ IF(ITYPLU .NE. 1) CALL XABORT(NAMSBR//
+ > ': Read error -- integer value for EDIT expected.')
+ IPRINT=INTLIR
+ ELSE IF(CARLIR .EQ. 'RNDPhysParam') THEN
+ IOPT(1)=1
+ CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR)
+ IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR//
+ >': Read error -- Character variable expected')
+ CARRET=CARLIR
+ GO TO 105
+ ELSE IF(CARLIR .EQ. 'GPTPhysParam') THEN
+ IOPT(1)=2
+ GO TO 105
+ ELSE IF(CARLIR .EQ. 'RNDMicXS') THEN
+ IOPT(1)=3
+ GO TO 105
+ ELSE IF(CARLIR .EQ. 'GPTMicXS') THEN
+ IOPT(1)=4
+ GO TO 105
+ ELSE
+ CALL XABORT(NAMSBR//': Read error -- keyword'//CARLIR//
+ >'for processing option is invalid.')
+ ENDIF
+ GO TO 100
+ 105 CONTINUE
+*----
+* Analyze structures
+* Find the first L_EPC structure or the first new structure
+*----
+ DO IEN=1,NENTRY
+ HET=HENTRY(IEN)
+ IF(IENTRY(IEN) .EQ. 1 .OR. IENTRY(IEN) .EQ. 2) THEN
+ IF(JENTRY(IEN) .EQ. 1) THEN
+ IF(SENTRY(IEN) .EQ. 'L_EPC ') THEN
+ CALL LCMGET(KENTRY(IEN),'STATE-VECTOR',ISTATE)
+ IF(IOPT(1) .NE. ISTATE(1)) CALL XABORT(NAMSBR//
+ >': Structure L_EPC :'//HET//
+ >' not compatible with processing option.')
+ IOPT(2)=IEN
+ IOPT(4)=ISTATE(2)
+ GO TO 120
+ ENDIF
+ ELSE
+ IOPT(2)=IEN
+ SENTRY(IEN)='L_EPC '
+ ISTATE(1)=IOPT(1)
+ HSIGN=SENTRY(IEN)
+ CALL LCMPTC(KENTRY(IEN),'SIGNATURE',12,HSIGN)
+ CALL LCMPUT(KENTRY(IEN),'STATE-VECTOR',NSTATE,1,ISTATE)
+ IF(ISTATE(1) .EQ. 0) THEN
+ HSIGN=' '
+ CALL LCMPTC(KENTRY(IEN),'ParametreNom',12,HSIGN)
+ CALL LCMPUT(KENTRY(IEN),'ParametreNbr',1,1,0)
+ CALL LCMPUT(KENTRY(IEN),'ParametreNxt',1,1,0)
+ CALL LCMPUT(KENTRY(IEN),'ParametreRef',1,2,0.0)
+ ENDIF
+ GO TO 120
+ ENDIF
+ ENDIF
+ ENDDO
+ CALL XABORT(NAMSBR//': No structure found for L_EPC.')
+ 120 CONTINUE
+*----
+* Find the first read_only SEQ_ASCII or BINARY file
+*----
+ DO IEN=1,NENTRY
+ IF(JENTRY(IEN) .EQ. 2) THEN
+ IF(IENTRY(IEN) .EQ. 3) THEN
+ IOPT(3)=-IEN
+ GO TO 130
+ ELSE IF(IENTRY(IEN) .EQ. 4) THEN
+ IOPT(3)=IEN
+ GO TO 130
+ ENDIF
+ ENDIF
+ ENDDO
+ 130 CONTINUE
+*----
+* Process option
+*----
+ IF(IOPT(1) .EQ. 1) THEN
+*----
+* Option RNDPhysParam
+*----
+ CALL EPCRPD(NENTRY,KENTRY,IPRINT,NOPT,IOPT,CARRET)
+ ELSE IF(IOPT(1) .EQ. 2) THEN
+*----
+* Option GPTPhysParam
+*----
+ CALL XABORT(NAMSBR//' Option GPTPhysParam not programmed yet')
+* CALL EPCGPD(NENTRY,KENTRY,IPRINT,NOPT,IOPT,CARRET)
+ ELSE IF(IOPT(1) .EQ. 3) THEN
+*----
+* Locate microlib
+*----
+ DO IEN=1,NENTRY
+ IF(IENTRY(IEN) .EQ. 1 .OR. IENTRY(IEN) .EQ. 2) THEN
+ IF(JENTRY(IEN) .EQ. 1) THEN
+ CALL LCMGTC(KENTRY(IEN),'SIGNATURE',12,HSIGN)
+ IF(HSIGN .EQ. 'L_LIBRARY ') THEN
+ IOPT(4)=IEN
+ GO TO 140
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDDO
+* CALL XABORT(NAMSBR//' Option RNDMicXS requires a microlib')
+ 140 CONTINUE
+*----
+* Process
+*----
+ CALL EPCRMD(NENTRY,KENTRY,IPRINT,NOPT,IOPT,CARRET)
+ ELSE IF(IOPT(1) .EQ. 4) THEN
+*----
+* Option GPTMicXS
+*----
+ CALL XABORT(NAMSBR//' Option GPTMicXS not programmed yet')
+* CALL EPCGMD(NENTRY,KENTRY,IPRINT,NOPT,IOPT,CARRET)
+ ENDIF
+*----
+* Processing finished, return
+*----
+ RETURN
+*----
+* Warning formats
+*----
+ END
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 13:17:43 +0000