Initial commit from Polytechnique Montreal

1 files changed, 187 insertions, 0 deletions

diff --git a/Ganlib/src/MSTPUT.f b/Ganlib/src/MSTPUT.f
new file mode 100644
index 0000000..93ec582
--- /dev/null
+++ b/Ganlib/src/MSTPUT.f
@@ -0,0 +1,187 @@
+*DECK MSTPUT
+      SUBROUTINE MSTPUT(IPSTR,IPRINT,IBEG,IEND,IINC,NAME,NBLOCK,BLNAM,
+     1           BLTYP,BLLEN)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Create or update a block in a structure from user input data.
+*
+*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): R. Le Tellier
+*
+*Parameters: input
+* IPSTR   structure address.
+* IPRINT  level of print index.
+* IBEG    index of the first element.
+* IEND    index of the last element.
+* IINC    index increment between two consecutive elements.
+* NAME    block name.
+* NBLOCK  number of existing block in the directory.
+* BLNAM   names of these blocks.
+* BLTYP   types of these blocks.
+* BLLEN   lengths of these blocks.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+      IMPLICIT NONE
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) :: IPSTR
+      INTEGER :: IPRINT,IBEG,IEND,IINC,NBLOCK,BLTYP(NBLOCK+1),
+     1           BLLEN(NBLOCK+1)
+      CHARACTER(LEN=12) :: BLNAM(NBLOCK+1),NAME 
+*----
+*  LOCAL VARIABLES
+*----
+      INTEGER, PARAMETER :: IOUT=6
+      INTEGER, PARAMETER :: NSTATE=40
+      INTEGER :: INDIC,NITMA,ISTATE(NSTATE),II,JJ,ITYPO,NELEO,ITYP,
+     1           NARA,SIZE
+      REAL :: FLOTT
+      DOUBLE PRECISION :: DFLOTT
+      CHARACTER(LEN=12) :: TEXT12,WHITE12
+      LOGICAL :: EXIST
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: IARA
+      REAL, ALLOCATABLE, DIMENSION(:) :: ARA
+      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DARA
+*
+*     BLOCK NAME
+      EXIST=.FALSE.
+      NELEO=0
+*     SPECIAL CASE OF STATE-VECTOR MODIFICATION
+      IF (NAME.EQ.'STATE-VECTOR') THEN
+         IF (IEND.GT.40)
+     1      CALL XABORT('MSTPUT: STATE-VECTOR SIZE IS LIMITED TO 40.')
+         IF (IEND.EQ.40)
+     2      CALL XABORT('MSTPUT: 40th STATE-VECTOR ELEMENT SHOULD'//
+     3      ' NOT BE MODIFIED.')
+         ITYPO=1
+         NELEO=NSTATE
+         EXIST=.TRUE.
+      ENDIF
+      IF (NBLOCK.NE.0) THEN
+*     IS THIS BLOCK ALREADY PART OF THE STRUCTURE ?
+         DO II=1,NBLOCK
+            IF(BLNAM(II).EQ.NAME) THEN
+               ITYPO=BLTYP(II)
+               IF (ITYPO.EQ.0)
+     1       CALL XABORT('MSTPUT: '//NAME//' IS AN EXISTING DIRECTORY.')
+               NELEO=BLLEN(II)
+               EXIST=.TRUE.
+               GOTO 20
+            ENDIF
+         ENDDO
+ 20      CONTINUE
+      ENDIF
+      IF (IPRINT.GT.2) THEN
+      IF (EXIST) THEN
+*     YES: IT WILL BE UPDATED
+         WRITE(IOUT,*) 'MSTPUT: BLOCK '//NAME//' IN UPDATE MODE'
+      ELSE
+*     NO: IT WILL BE CREATED
+         WRITE(IOUT,*) 'MSTPUT: BLOCK '//NAME//' IN CREATION MODE'
+      ENDIF
+      ENDIF
+*     FIRST ELEMENT
+      CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+      ITYP=INDIC
+      IF ((EXIST).AND.(ITYP.NE.ITYPO))
+     1   CALL XABORT('MSTPUT: HETEROGENEOUS BLOCK NOT SUPPORTED')
+      IF (INDIC.GT.4)
+     1   CALL XABORT('MSTPUT: UNSUPPORTED TYPE(1)')
+      NARA=MAX(IEND,NELEO)
+*     ALLOCATE MEMORY
+      IF (ITYP.EQ.1) THEN
+         SIZE=NARA
+         ALLOCATE(IARA(NARA))
+      ELSEIF (ITYP.EQ.2) THEN
+         SIZE=NARA
+         ALLOCATE(ARA(NARA))
+      ELSEIF (ITYP.EQ.3) THEN
+         SIZE=3*NARA
+         ALLOCATE(IARA(3*NARA))
+      ELSEIF (ITYP.EQ.4) THEN
+         SIZE=NARA
+         ALLOCATE(DARA(NARA))
+      ENDIF
+*     INITIALIZE BLOCK
+      IF (EXIST) THEN
+         IF (ITYP.EQ.1) THEN
+            CALL LCMGET(IPSTR,NAME,IARA)
+         ELSEIF (ITYP.EQ.2) THEN
+            CALL LCMGET(IPSTR,NAME,ARA)
+         ELSEIF (ITYP.EQ.3) THEN
+            CALL LCMGET(IPSTR,NAME,IARA)
+         ELSEIF (ITYP.EQ.4) THEN
+            CALL LCMGET(IPSTR,NAME,DARA)
+         ENDIF
+      ELSE
+         IF (ITYP.EQ.1) THEN
+            IARA(:IEND)=0
+         ELSEIF (ITYP.EQ.2) THEN
+            ARA(:IEND)=0.0
+         ELSEIF (ITYP.EQ.3) THEN
+            WHITE12=' '
+            DO II=1,IEND
+               READ(WHITE12,'(3A4)') (IARA(3*(II-1)+JJ),JJ=0,2)
+            ENDDO
+         ELSEIF (ITYP.EQ.4) THEN
+            DARA(:IEND)=0.D0
+         ENDIF
+      ENDIF
+*     RETRIEVE USER'S INPUT VALUES
+      DO II=IBEG,IEND,IINC
+         IF (INDIC.NE.ITYP)
+     1      CALL XABORT('MSTPUT: HETEROGENEOUS BLOCK NOT SUPPORTED')
+         IF (INDIC.EQ.1) THEN
+            IARA(II)=NITMA
+         ELSEIF (INDIC.EQ.2) THEN
+            ARA(II)=FLOTT
+         ELSEIF (INDIC.EQ.3) THEN
+            READ(TEXT12,'(3A4)') (IARA(3*(II-1)+JJ),JJ=0,2)
+         ELSEIF (INDIC.EQ.4) THEN
+            DARA(II)=DFLOTT
+         ELSE
+            CALL XABORT('MSTPUT: UNSUPPORTED TYPE(2)')
+         ENDIF
+         IF (II.LT.IEND) CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+      ENDDO
+      IF (INDIC.EQ.1) THEN
+         CALL LCMPUT(IPSTR,NAME,SIZE,ITYP,IARA)
+         DEALLOCATE(IARA)
+      ELSEIF (INDIC.EQ.2) THEN
+         CALL LCMPUT(IPSTR,NAME,SIZE,ITYP,ARA)
+         DEALLOCATE(ARA)
+      ELSEIF (INDIC.EQ.3) THEN
+         CALL LCMPUT(IPSTR,NAME,SIZE,ITYP,IARA)
+         DEALLOCATE(IARA)
+      ELSEIF (INDIC.EQ.4) THEN
+         CALL LCMPUT(IPSTR,NAME,SIZE,ITYP,DARA)
+         DEALLOCATE(DARA)
+      ENDIF
+*----
+*  UPDATE NB. BLOCKS, REC-NAMES, REC-TYPES, REC-LENGTHS IN STATE-VECTOR
+*  IF REQUIRED
+*----
+      IF (.NOT.EXIST) THEN
+         CALL LCMGET(IPSTR,'STATE-VECTOR',ISTATE)
+         ISTATE(40)=ISTATE(40)+1
+         BLNAM(NBLOCK+1)=NAME
+         BLTYP(NBLOCK+1)=ITYP
+         BLLEN(NBLOCK+1)=NARA
+         CALL LCMPUT(IPSTR,'STATE-VECTOR',NSTATE,1,ISTATE)
+         CALL LCMPTC(IPSTR,'REC-NAMES',12,NBLOCK+1,BLNAM)
+         CALL LCMPUT(IPSTR,'REC-TYPES',(NBLOCK+1),1,BLTYP)
+         CALL LCMPUT(IPSTR,'REC-LENGTHS',(NBLOCK+1),1,BLLEN)
+      ENDIF
+      RETURN
+      END