diff options
Diffstat (limited to 'Ganlib/src/MSTPUT.f')
| -rw-r--r-- | Ganlib/src/MSTPUT.f | 187 |
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 |