Initial commit from Polytechnique Montreal

1 files changed, 133 insertions, 0 deletions

diff --git a/Dragon/src/EPCRPD.f b/Dragon/src/EPCRPD.f
new file mode 100644
index 0000000..9e3cdce
--- /dev/null
+++ b/Dragon/src/EPCRPD.f
@@ -0,0 +1,133 @@
+*DECK EPCRPD
+      SUBROUTINE EPCRPD(NENTRY,KENTRY,IPRINT,NOPT,IOPT,CARRET)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* To extract library parameters with normal distribution
+* around the average.
+*
+*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.
+* KENTRY  data structure pointer.
+* IPRINT  print level.
+* NOPT    number of options.
+* IOPT    processing option with:
+*         IOPT(1)  type of processing (=0 for current option);
+*         IOPT(2)  entry position for L_EPC structure;
+*         IOPT(3)  number of parameters;
+*         IOPT(4)  entry for normal distribution file;
+*         IOPT(5)  number of records on normal distribution file.
+* CARRET  last input option read.
+*
+*-----------------------------------------------------------------------
+*
+      USE              GANLIB
+      IMPLICIT         NONE
+*----
+*  Subroutine arguments
+*----
+      INTEGER          NENTRY
+      TYPE(C_PTR)      KENTRY(NENTRY)
+      INTEGER          IPRINT,NOPT,IOPT(NOPT)
+      CHARACTER*12     CARRET
+*----
+*  Local parameters
+*----
+      INTEGER          IOUT
+      CHARACTER        NAMSBR*6
+      PARAMETER       (IOUT=6,NAMSBR='EPCRPD')
+      INTEGER          ILCMUP,ILCMDN
+      PARAMETER       (ILCMUP=1,ILCMDN=2)
+      INTEGER          NSTATE
+      PARAMETER       (NSTATE=40)
+*----
+*  Input and output parameters
+*----
+      INTEGER          ITYPLU,INTLIR
+      CHARACTER        CARLIR*12
+      REAL             REALIR
+      DOUBLE PRECISION DBLLIR
+*----
+*  Local variables
+*----
+      TYPE(C_PTR)      IPNDI
+      INTEGER          IKNDI
+      INTEGER          ISTATE(NSTATE)
+      INTEGER          NOREC,NTREC,NFREC,MAXD
+*----
+*  Output structure
+*----
+      IKNDI=1
+      IF(IOPT(3) .EQ. 0) IKNDI=-1
+      IPNDI=KENTRY(IOPT(2))
+      CALL LCMGET(IPNDI,'STATE-VECTOR',ISTATE)
+*----
+*  Input structure
+*----
+      NOREC=ISTATE(1)
+      MAXD=ISTATE(2)
+      NTREC=IOPT(5)
+*----
+*  Recover parameter names from output and input structures
+*----
+      NFREC=NTREC+NOREC
+      ISTATE(1)=NFREC
+      ISTATE(2)=MAXD
+      CALL LCMPUT(IPNDI,'STATE-VECTOR',NSTATE,1,ISTATE)
+*----
+*  INPUT/OUTPUT VARIABLES
+*  Input data is of the form
+*    [ EDIT iprint ]
+*    [ SET (dataSET) ]
+*    [ GET (dataGET) ]
+*  where
+*  EDIT               = keyword for print level
+*  iprint             = integer print level
+*  SET                = keyword to set reference value
+*                       and extract number of parameters
+*  GET                = keyword to set next value
+*                       and to extract parameter
+*  (dataSET)          = SET data processed by NDISET
+*  (dataGET)          = GET data processed by NDIGET
+*----
+      IPRINT=1
+ 100  CONTINUE
+      CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR)
+ 101  CONTINUE
+      IF(ITYPLU .EQ. 10) GO TO 105
+      IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR//
+     >': Read error -- Character variable expected')
+      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. 'SET') THEN
+        CARRET=CARLIR
+        CARLIR=CARRET
+        GO TO 101
+      ELSE IF(CARLIR .EQ. 'GET') THEN
+        CARRET=CARLIR
+        CARLIR=CARRET
+        GO TO 101
+      ELSE
+        CALL XABORT(NAMSBR//
+     >  ': '//CARLIR//' is an invalid keyword.')
+      ENDIF
+      GO TO 100
+ 105  CONTINUE
+      RETURN
+      END