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
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
|
*DECK MSTCPB
SUBROUTINE MSTCPB(IPSTR,IPSTR2,IPRINT,IBEG,IEND,IINC,NAME,NAME2,
1 NBLOCK,BLNAM,BLTYP,BLLEN)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Copy some elements from a structure's block to another.
*
*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 address of the structure from which the information is
* retrieved.
* IPSTR2 destination 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 name of the block from which the information is retrieved.
* NAME2 destination 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,IPSTR2
INTEGER :: IPRINT,IBEG,IEND,IINC,NBLOCK,BLTYP(NBLOCK+1),
1 BLLEN(NBLOCK+1)
CHARACTER(LEN=12) :: BLNAM(NBLOCK+1),NAME,NAME2
*----
* LOCAL VARIABLES
*----
INTEGER, PARAMETER :: IOUT=6,NSTATE=40
INTEGER :: ISTATE(NSTATE),NARA,ITYP,SIZE,ITYPO,NELEO,NARA2,II,JJ,
1 SIZE2
CHARACTER(LEN=12) :: WHITE12
LOGICAL :: EXIST
INTEGER, ALLOCATABLE, DIMENSION(:) :: IARA,IARA2
REAL, ALLOCATABLE, DIMENSION(:) :: ARA,ARA2
DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DARA,DARA2
*----
* RETRIEVING BLOCK TO BE COPIED
*----
CALL LCMLEN(IPSTR,NAME,SIZE,ITYP)
IF (SIZE.LE.0) THEN
CALL LCMLIB(IPSTR)
CALL XABORT('MSTCPB: INVALID BLOCK '//NAME//'.')
ENDIF
NARA=0
IF (ITYP.EQ.1) THEN
NARA=SIZE
ALLOCATE(IARA(NARA))
CALL LCMGET(IPSTR,NAME,IARA)
ELSEIF (ITYP.LE.2) THEN
NARA=SIZE
ALLOCATE(ARA(NARA))
CALL LCMGET(IPSTR,NAME,ARA)
ELSEIF (ITYP.EQ.3) THEN
NARA=SIZE/3
ALLOCATE(IARA(3*NARA))
CALL LCMGET(IPSTR,NAME,IARA)
ELSEIF (ITYP.EQ.4) THEN
NARA=SIZE
ALLOCATE(DARA(NARA))
CALL LCMGET(IPSTR,NAME,DARA)
ELSE
CALL XABORT('MSTCPB: UNSUPPORTED TYPE')
ENDIF
IF (IEND.GT.NARA) CALL XABORT('MSTCPB: INCOMPATIBLE SIZE')
* DOES THIS BLOCK ALREADY EXIST IN THE DESTINATION STRUCTURE ?
EXIST=.FALSE.
NELEO=0
* SPECIAL CASE OF STATE-VECTOR MODIFICATION
IF (NAME2.EQ.'STATE-VECTOR') THEN
IF (IEND.GT.40)
1 CALL XABORT('MSTCPM: STATE-VECTOR SIZE IS LIMITED TO 40.')
IF (IEND.EQ.40)
2 CALL XABORT('MSTCPM: 40th STATE-VECTOR ELEMENT SHOULD'//
3 ' NOT BE MODIFIED.')
ITYPO=1
NELEO=NSTATE
EXIST=.TRUE.
ENDIF
IF (NBLOCK.NE.0) THEN
DO II=1,NBLOCK
IF(BLNAM(II).EQ.NAME2) THEN
ITYPO=BLTYP(II)
IF (ITYPO.EQ.0)
1 CALL XABORT('MSTCPM: '//NAME2//
2 ' IS AN EXISTING DIRECTORY.')
IF (ITYPO.NE.ITYP)
1 CALL XABORT('MSTCPM: INCOMPATIBLE TYPES')
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,*) 'MSTCPB: BLOCK '//NAME//' IN UPDATE MODE'
ELSE
* NO: IT WILL BE CREATED
WRITE(IOUT,*) 'MSTCPB: BLOCK '//NAME//' IN CREATION MODE'
ENDIF
ENDIF
NARA2=MAX(NARA,NELEO)
* ALLOCATE MEMORY
IF (ITYP.EQ.1) THEN
SIZE2=NARA2
ALLOCATE(IARA2(NARA2))
ELSEIF (ITYP.EQ.2) THEN
SIZE2=NARA2
ALLOCATE(ARA2(NARA2))
ELSEIF (ITYP.EQ.3) THEN
SIZE2=3*NARA2
ALLOCATE(IARA2(3*NARA2))
ELSEIF (ITYP.EQ.4) THEN
SIZE2=NARA2
ALLOCATE(DARA2(NARA2))
ENDIF
* INITIALIZE BLOCK
IF (EXIST) THEN
IF (ITYP.EQ.1) THEN
CALL LCMGET(IPSTR2,NAME2,IARA2)
ELSEIF (ITYP.EQ.2) THEN
CALL LCMGET(IPSTR2,NAME2,ARA2)
ELSEIF (ITYP.EQ.3) THEN
CALL LCMGET(IPSTR2,NAME2,IARA2)
ELSEIF (ITYP.EQ.4) THEN
CALL LCMGET(IPSTR2,NAME2,DARA2)
ENDIF
ELSE
IF (ITYP.EQ.1) THEN
IARA2(:NARA)=0
ELSEIF (ITYP.EQ.2) THEN
ARA2(:NARA)=0
ELSEIF (ITYP.EQ.3) THEN
WHITE12=' '
DO II=1,NARA
READ(WHITE12,'(3A4)') (IARA2(3*(II-1)+JJ),JJ=0,2)
ENDDO
ELSEIF (ITYP.EQ.4) THEN
DARA2(:NARA)=0.D0
ENDIF
ENDIF
* COPY ACTION
DO II=IBEG,IEND,IINC
IF (ITYP.EQ.1) THEN
IARA2(II)=IARA(II)
ELSEIF (ITYP.EQ.2) THEN
ARA2(II)=ARA(II)
ELSEIF (ITYP.EQ.3) THEN
DO JJ=0,2
IARA2(3*(II-1)+JJ)=IARA(3*(II-1)+JJ)
ENDDO
ELSEIF (ITYP.EQ.4) THEN
DARA2(II)=DARA(II)
ENDIF
ENDDO
IF (ITYP.EQ.1) THEN
CALL LCMPUT(IPSTR2,NAME2,SIZE2,ITYP,IARA2)
DEALLOCATE(IARA2)
DEALLOCATE(IARA)
ELSEIF (ITYP.EQ.2) THEN
CALL LCMPUT(IPSTR2,NAME2,SIZE2,ITYP,ARA2)
DEALLOCATE(ARA2)
DEALLOCATE(ARA)
ELSEIF (ITYP.EQ.3) THEN
CALL LCMPUT(IPSTR2,NAME2,SIZE2,ITYP,IARA2)
DEALLOCATE(IARA2)
DEALLOCATE(IARA)
ELSEIF (ITYP.EQ.4) THEN
CALL LCMPUT(IPSTR2,NAME2,SIZE2,ITYP,DARA2)
DEALLOCATE(DARA2)
DEALLOCATE(DARA)
ENDIF
*----
* UPDATE NB. BLOCKS, REC-NAMES, REC-TYPES, REC-LENGTHS IN STATE-VECTOR
* IF REQUIRED
*----
IF (.NOT.EXIST) THEN
CALL LCMGET(IPSTR2,'STATE-VECTOR',ISTATE)
ISTATE(40)=ISTATE(40)+1
BLNAM(NBLOCK+1)=NAME
BLTYP(NBLOCK+1)=ITYP
BLLEN(NBLOCK+1)=NARA
CALL LCMPUT(IPSTR2,'STATE-VECTOR',NSTATE,1,ISTATE)
CALL LCMPTC(IPSTR2,'REC-NAMES',12,NBLOCK+1,BLNAM)
CALL LCMPUT(IPSTR2,'REC-TYPES',(NBLOCK+1),1,BLTYP)
CALL LCMPUT(IPSTR2,'REC-LENGTHS',(NBLOCK+1),1,BLLEN)
ENDIF
RETURN
END
|
