1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
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
|
