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
212
213
214
215
216
217
218
219
220
221
222
|
*DECK MSTR
SUBROUTINE MSTR(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Manage user-defined structures.
*
*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/output
* NENTRY number of LCM objects or files used by the operator.
* HENTRY name of each LCM object or file:
* HENTRY(1): modification type(VECTOR);
* HENTRY(2): read-only type(VECTOR).
* IENTRY type of each LCM object or file:
* =1 LCM memory object; =2 XSM file; =3 sequential binary file;
* =4 sequential ascii file.
* JENTRY access of each LCM object or file:
* =0 the LCM object or file is created;
* =1 the LCM object or file is open for modifications;
* =2 the LCM object or file is open in read-only mode.
* KENTRY LCM object address or file unit number.
*
*-----------------------------------------------------------------------
*
USE GANLIB
*----
* SUBROUTINE ARGUMENTS
*----
INTEGER NENTRY
CHARACTER HENTRY(NENTRY)*12
INTEGER IENTRY(NENTRY),JENTRY(NENTRY)
TYPE(C_PTR) KENTRY(NENTRY)
*----
* LOCAL VARIABLES
*----
INTEGER I,ACSTR,TYSTR,ACSTRO,TYSTRO,ACSTR2,TYSTR2
INTEGER, PARAMETER :: IOUT=6
INTEGER, PARAMETER :: NSTATE=40
INTEGER INDIC,NITMA,ISTATE(NSTATE),IPRINT,NBLOCK,ILEN,ITYP,NBDIR
REAL FLOTT
DOUBLE PRECISION DFLOTT
CHARACTER TEXT4*4,NAME*12,PATH*72,DIRS(37)*12,NAME2*12,TEXT12*12
LOGICAL ROOT
TYPE(C_PTR) IPSTR,IPSTRO,IPSTR2
CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: BLNAM
INTEGER, ALLOCATABLE, DIMENSION(:) :: BLTYP,BLLEN
*----
* PARAMETER VALIDATION
*----
IF(NENTRY.LT.1)
1 CALL XABORT('MSTR: AT LEAST ONE PARAMETER EXPECTED.')
DO I=1,NENTRY
IF(IENTRY(I).GT.2)
1 CALL XABORT('MSTR: LINKED LIST OR XSM EXPECTED.')
ENDDO
*----
* CREATE STATE-VECTOR/SIGNATURE FOR STRUCTURES IN CREATION MODE
* VERIFY IF IT EXISTS FOR STRUCTURES IN MODIFICATION MODE
*----
DO I=1,NENTRY
ACSTR=JENTRY(I)
IPSTR=KENTRY(I)
IF (ACSTR.EQ.0) THEN
* THE STRUCTURE IS CREATED:
* ASSIGN IT A DEFAULT SIGNATURE AND A STATE-VECTOR
NAME='VECTOR'
CALL LCMPTC(IPSTR,'SIGNATURE',12,NAME)
ISTATE(:NSTATE)=0
CALL LCMPUT(IPSTR,'STATE-VECTOR',NSTATE,1,ISTATE)
ELSEIF (ACSTR.EQ.1) THEN
CALL LCMLEN(IPSTR,'SIGNATURE',ILEN,ITYP)
IF ((ILEN.NE.3).OR.(ITYP.NE.3))
1 CALL XABORT('MSTR: INVALID SIGNATURE FOR '//HENTRY(I)
2 //'.')
CALL LCMLEN(IPSTR,'STATE-VECTOR',ILEN,ITYP)
IF ((ILEN.NE.40).OR.(ITYP.NE.1))
1 CALL XABORT('MSTR: INVALID STATE-VECTOR FOR '//HENTRY(I)
2 //'.')
ENDIF
ENDDO
*---
* PROCESS USER'S INPUT
*---
IPRINT=0
ACSTR=JENTRY(1)
TYSTR=IENTRY(1)
IPSTR=KENTRY(1)
ACSTR2=ACSTR
TYSTR2=TYSTR
IPSTR2=IPSTR
50 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT)
IF(INDIC.EQ.10) GO TO 60
IF(INDIC.NE.3) CALL XABORT('MSTR: CHARACTER DATA EXPECTED(1).')
IF(TEXT4.EQ.'EDIT') THEN
* MODULE EDITION LEVEL
CALL REDGET(INDIC,IPRINT,FLOTT,TEXT4,DFLOTT)
IF(INDIC.NE.1) CALL XABORT('MSTR: INTEGER DATA EXPECTED(1).')
ELSEIF(TEXT4.EQ.'TYPE') THEN
* USER DEFINED TYPE FOR THE STRUCTURE
CALL REDGET(INDIC,NITMA,FLOTT,PATH,DFLOTT)
IF(INDIC.NE.3)
1 CALL XABORT('MSTR: CHARACTER DATA EXPECTED(2).')
CALL MSTANP(NENTRY,IENTRY,JENTRY,KENTRY,PATH,IPSTR,
1 ACSTR,TYSTR,NBDIR,DIRS,ROOT)
IF (NBDIR.NE.1) CALL XABORT('MSTR: INVALID TYPE ENTRY.')
CALL LCMPTC(IPSTR,'SIGNATURE',12,DIRS(1))
ELSEIF((TEXT4.EQ.'PUT').OR.
1 (TEXT4.EQ.'GET').OR.
2 (TEXT4.EQ.'CP')) THEN
* PUT, GET OR CP ACTION
CALL REDGET(INDIC,NELEM,FLOTT,TEXT12,DFLOTT)
* NUMBER OF ELEMENTS
IF(INDIC.NE.1) CALL XABORT('MSTR: INTEGER DATA EXPECTED(2).')
IBEG=1
IEND=NELEM
IINC=1
CALL REDGET(INDIC,NITMA,FLOTT,PATH,DFLOTT)
IF(INDIC.EQ.1) THEN
* STARTING INDEX
IBEG=NITMA
CALL REDGET(INDIC,NITMA,FLOTT,PATH,DFLOTT)
IF(INDIC.EQ.1) THEN
* INCREMENT
IINC=NITMA
ELSE
GOTO 10
ENDIF
CALL REDGET(INDIC,NITMA,FLOTT,PATH,DFLOTT)
ENDIF
10 CONTINUE
IEND=IBEG+(NELEM-1)*IINC
IF (INDIC.NE.3)
1 CALL XABORT('MSTR: CHARACTER DATA EXPECTED(3).')
IPSTRO=IPSTR
ACSTRO=ACSTR
TYSTRO=TYSTR
* ANALYSE USER'S PATH
CALL MSTANP(NENTRY,IENTRY,JENTRY,KENTRY,PATH,IPSTR,
1 ACSTR,TYSTR,NBDIR,DIRS,ROOT)
* GO TO REQUESTED DIRECTORY
IF (NBDIR.GT.1) THEN
CALL MSTMOV(IPSTR,ACSTR,IPRINT,NBDIR-1,DIRS,ROOT)
ENDIF
NAME=DIRS(NBDIR)
IF (TEXT4.EQ.'PUT') THEN
* CREATING OR UPDATING DATA IN A BLOCK
IF (ACSTR.EQ.2)
1 CALL XABORT('MSTR: PUT NOT PERMITTED IN READ-ONLY MODE')
CALL LCMGET(IPSTR,'STATE-VECTOR',ISTATE)
NBLOCK=ISTATE(40)
ALLOCATE(BLNAM(NBLOCK+1),BLTYP(NBLOCK+1),BLLEN(NBLOCK+1))
IF (NBLOCK.GT.0) THEN
CALL LCMGTC(IPSTR,'REC-NAMES',12,NBLOCK+1,BLNAM)
CALL LCMGET(IPSTR,'REC-TYPES',BLTYP)
CALL LCMGET(IPSTR,'REC-LENGTHS',BLLEN)
ENDIF
CALL MSTPUT(IPSTR,IPRINT,IBEG,IEND,IINC,NAME,NBLOCK,BLNAM,
1 BLTYP,BLLEN)
DEALLOCATE(BLLEN,BLTYP,BLNAM)
ELSEIF(TEXT4.EQ.'GET') THEN
* RETRIEVING DATA FROM A BLOCK
CALL MSTGET(IPSTR,IPRINT,IBEG,IEND,IINC,NAME)
ELSEIF(TEXT4.EQ.'CP') THEN
* COPYING A BLOCK FROM ONE PLACE TO ANOTHER
CALL REDGET(INDIC,NITMA,FLOTT,PATH,DFLOTT)
IF (INDIC.NE.3)
1 CALL XABORT('MSTR: CHARACTER DATA EXPECTED(4).')
* ANALYSE USER'S PATH
CALL MSTANP(NENTRY,IENTRY,JENTRY,KENTRY,PATH,IPSTR2,
1 ACSTR2,TYSTR2,NBDIR,DIRS,ROOT)
IF (ACSTR2.EQ.2)
1 CALL XABORT('MSTR: CP NOT PERMITTED IN READ-ONLY MODE')
* GO TO REQUESTED DIRECTORY
IF (NBDIR.GT.1) THEN
CALL MSTMOV(IPSTR2,ACSTR2,IPRINT,NBDIR-1,DIRS,ROOT)
ENDIF
NAME2=DIRS(NBDIR)
CALL LCMGET(IPSTR2,'STATE-VECTOR',ISTATE)
NBLOCK=ISTATE(40)
ALLOCATE(BLNAM(NBLOCK+1),BLTYP(NBLOCK+1),BLLEN(NBLOCK+1))
IF (NBLOCK.GT.0) THEN
CALL LCMGTC(IPSTR2,'REC-NAMES',12,NBLOCK+1,BLNAM)
CALL LCMGET(IPSTR2,'REC-TYPES',BLTYP)
CALL LCMGET(IPSTR2,'REC-LENGTHS',BLLEN)
ENDIF
CALL MSTCPB(IPSTR,IPSTR2,IPRINT,IBEG,IEND,IINC,NAME,NAME2,
1 NBLOCK,BLNAM,BLTYP,BLLEN)
DEALLOCATE(BLLEN,BLTYP,BLNAM)
ENDIF
IPSTR=IPSTRO
ACSTR=ACSTRO
TYSTR=TYSTRO
ELSEIF(TEXT4.EQ.'CD') THEN
* CHANGING DIRECTORY
CALL REDGET(INDIC,NITMA,FLOTT,PATH,DFLOTT)
IF(INDIC.NE.3)
1 CALL XABORT('MSTR: CHARACTER DATA EXPECTED(5).')
* ANALYSE USER'S PATH
CALL MSTANP(NENTRY,IENTRY,JENTRY,KENTRY,PATH,IPSTR,
1 ACSTR,TYSTR,NBDIR,DIRS,ROOT)
* GO TO REQUESTED DIRECTORY
CALL MSTMOV(IPSTR,ACSTR,IPRINT,NBDIR,DIRS,ROOT)
ELSEIF(TEXT4.EQ.';') THEN
GOTO 60
ELSE
CALL XABORT('MSTR: '//TEXT4//' IS AN INVALID KEY WORD.')
ENDIF
GOTO 50
*
60 CONTINUE
*
RETURN
END
|
