-
Notifications
You must be signed in to change notification settings - Fork 49
/
Copy pathcmo_addatt_cmo.f
executable file
·372 lines (363 loc) · 11.8 KB
/
cmo_addatt_cmo.f
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
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
subroutine cmo_addatt_cmo(imsgin,xmsgin,cmsgin,msgtype,nwds,
* ierror_return)
C
C
C#######################################################################
C
C PURPOSE -
C
C This Routine Adds Attributes to an existing Mesh Object.
C
C INPUT ARGUMENTS -
C
C imsgin() - Integer array of command input tokens
C xmsgin() - Real array of command input tokens
C cmsgin() - Character array of command input tokens
C msgtype() - Integer array of command input token types
C nwds - Number of command input tokens
C
C OUTPUT ARGUMENTS -
C
C ierror_return - Error Return Code (==0 ==> OK, <>0 ==> Error)
C
C CHANGE HISTORY -
C
C $Log: cmo_addatt_cmo.f,v $
C Revision 2.00 2007/11/05 19:45:47 spchu
C Import to CVS
C
CPVCS
CPVCS Rev 1.9 07 Jul 2006 08:49:12 gable
CPVCS Modified screen output to reduce blank space.
CPVCS
CPVCS Rev 1.8 28 Aug 2001 10:51:42 dcg
CPVCS set persistence to value input via cmsgin (used to be hard wired 'temporary')
CPVCS
CPVCS Rev 1.7 10 Apr 2001 11:04:08 dcg
CPVCS shorten too long name
CPVCS
CPVCS Rev 1.6 17 Feb 2000 20:44:16 jtg
CPVCS added verbosity flag in 12th position so tone down screen output
CPVCS for calls from iterative routines like copyatt_mpary_lg if
CPVCS desired
CPVCS
CPVCS Rev 1.5 07 Feb 2000 16:45:42 dcg
CPVCS
CPVCS Rev 1.4 Tue Feb 01 13:40:02 2000 dcg
CPVCS
CPVCS Rev 1.3 Mon Jan 31 09:54:56 2000 dcg
CPVCS
CPVCS Rev 1.14 Tue Nov 02 19:08:16 1999 jtg
CPVCS fixed hardwired character*32 for cmsgin
CPVCS
CPVCS Rev 1.13 Mon Apr 14 16:39:50 1997 pvcs
CPVCS No change.
CPVCS
CPVCS Rev 1.12 Thu Jan 30 19:35:30 1997 het
CPVCS Refresh the ipcmoatt pointer because the memory was being
CPVCS changed but the pointer was not updates.
CPVCS
CPVCS Rev 1.11 11/13/95 16:21:16 dcg
CPVCS allocate integer arrays for VINT - real for VDOUBLE
CPVCS
CPVCS Rev 1.10 11/07/95 17:15:34 dcg
CPVCS change flag to 2 in mmgetblk calls
CPVCS
CPVCS Rev 1.9 10/16/95 10:21:16 het
CPVCS Correct sbnloc/sbnstor pointer problem
CPVCS
CPVCS Rev 1.8 09/15/95 10:32:18 dcg
CPVCS fix index field for new attribute
CPVCS
CPVCS Rev 1.6 09/13/95 16:45:34 dcg
CPVCS replace character literals in argument lists with
CPVCS character variables
CPVCS
CPVCS Rev 1.5 09/11/95 14:43:10 het
CPVCS Change to the storage block based CMO stuff.
CPVCS
CPVCS Rev 1.4 03/15/95 15:22:14 ejl
CPVCS Finished installing the defaults.
CPVCS
CPVCS Rev 1.3 02/16/95 10:22:54 ejl
CPVCS Put return afer end statement.
CPVCS
CPVCS Rev 1.2 02/16/95 09:55:36 ejl
CPVCS Fixed bugs, fixed hole in the Create command.
CPVCS Added commands MODATT, LENGTH, MEMORY, & COMPRESS.
CPVCS
CPVCS Rev 1.1 02/10/95 14:06:26 ejl
CPVCS Fix bugs left from last update.
C
C#######################################################################
C
implicit none
C
C#######################################################################
C
include 'cmo_lg.h'
C
C#######################################################################
C
integer nwds, imsgin(nwds), msgtype(nwds)
REAL*8 xmsgin(nwds)
character*(*) cmsgin(nwds)
C
integer ierror_return
C
C#######################################################################
C
C LOCAL VARIABLE DEFINITION
C
character*32 cmo_name, att_name, ctype,crank,clength
integer j, icmo_index,ierror,len,natts,i,lout,itype,
* posname,postype,posrank,poslen,posint,posio,pospers
integer lentype, length, irank, mmlength, ierr, ier
* , icscode, verbosity
C
character*132 logmess
C
integer idefault
real*8 xdefault
character*32 cdefault
C
pointer (ipcmo_pointer, icmo_pointer)
pointer (ipcmo_pointer, xcmo_pointer)
pointer (ipcmo_pointer, ccmo_pointer)
integer icmo_pointer(*)
REAL*8 xcmo_pointer(*)
character*32 ccmo_pointer(*)
C
character*32 partname
C
C#######################################################################
C
integer icharlnf
C
C#######################################################################
C
C
C
if (nwds.ge.12.and.msgtype(12).eq.1) then
verbosity=imsgin(12)
else
verbosity=1
endif
if (nwds.lt.4) goto 9998
partname='define_cmo_lg'
cmo_name = cmsgin(3)
att_name = cmsgin(4)
C
if((cmo_name(1:icharlnf(cmo_name))) .eq. '-def-') then
call cmo_get_name(cmo_name, ier)
if(ier.ne.0) then
write(logmess,9000) cmo_name(1:icharlnf(cmo_name))
9000 format(" ADDATT: CMO found bad mesh object: ",a)
call writloga('default',0,logmess,0,ier)
ierror_return = 1
goto 9999
endif
endif
C Check the mesh object name
call cmo_exist(cmo_name,ier)
if(ier.ne.0) then
write(logmess,'(a,a)')
* 'ADDATT: Not a valid mesh object: ',
* cmo_name(1:icharlnf(cmo_name))
call writloga('default',1,logmess,1,ier)
ierror_return = 1
goto 9999
endif
C
C.... Check if this a new Attribute.
C
C
call cmo_get_index(cmo_name,icmo_index,ierror)
C
if(ierror.ne.0) go to 9998
call mmfindbk('cmo_natts',partname,ipcmo_natts,len,
* icscode)
natts=cmo_natts(icmo_index)
call mmfindbk('cmo_attlist',cmo_name,ipcmo_attlist,
* len,icscode)
do i=1,natts
if(cmo_attlist(number_of_params_per_att*(i-1)+1)
* .eq.att_name) then
C
C... Existing Attribute.
C
C
if (verbosity.gt.0) then
ierror_return=-1
write(logmess,'(a,a,2x,a)')
* 'CMO_ADDATT warning: attribute already exist: ',
* cmo_name(1:icharlnf(cmo_name)),
* att_name(1:icharlnf(att_name))
call writloga('default',0,logmess,0,ierr)
else
ierror_return=-2
endif
C
go to 9999
endif
enddo
C
C.... This is a new attribute.
C
ierror_return=0
natts=natts+1
cmo_natts(icmo_index)=natts
C
C.... See if there is enough space for new attribute
C
call mmfindbk('cmo_attlist',cmo_name,ipcmo_attlist,len,icscode)
if(len.lt.natts*number_of_params_per_att) then
call mmincblk('cmo_attlist',cmo_name,ipcmo_attlist,
* number_of_params_per_att*20,icscode)
endif
C
c.... Find postions of name, type, rank and length
10 call mmfindbk( 'defcmo_attparam_names',partname,
* ipdefcmo_attparam_names,len,icscode)
call mmfindbk( 'cmo_attparam_idefault',cmo_name,
* ipcmo_attparam_idefault,len,icscode)
if(len.lt.natts) call mmincblk( 'cmo_attparam_idefault',
* cmo_name,ipcmo_attparam_idefault,20,icscode)
call mmfindbk( 'cmo_attparam_rdefault',cmo_name,
* ipcmo_attparam_rdefault,len,icscode)
if(len.lt.natts) call mmincblk( 'cmo_attparam_rdefault',
* cmo_name,ipcmo_attparam_rdefault,20,icscode)
call mmfindbk( 'cmo_attparam_cdefault',cmo_name,
* ipcmo_attparam_cdefault,len,icscode)
if(len.lt.natts) call mmincblk( 'cmo_attparam_cdefault',
* cmo_name,ipcmo_attparam_cdefault,20,icscode)
do i=1,number_of_default_attparam_name
if(defcmo_attparam_names(i).eq.'name') posname=i
if(defcmo_attparam_names(i).eq.'type') postype=i
if(defcmo_attparam_names(i).eq.'rank') posrank=i
if(defcmo_attparam_names(i).eq.'length') poslen=i
if(defcmo_attparam_names(i).eq.'interpolation') posint=i
if(defcmo_attparam_names(i).eq.'persistence') pospers=i
if(defcmo_attparam_names(i).eq.'ioflag') posio=i
enddo
cmo_attlist(number_of_params_per_att*(natts-1)+posname)=att_name
cmo_attlist(number_of_params_per_att*(natts-1)+postype)=cmsgin(5)
cmo_attlist(number_of_params_per_att*(natts-1)+posrank)=cmsgin(6)
cmo_attlist(number_of_params_per_att*(natts-1)+poslen)=cmsgin(7)
cmo_attlist(number_of_params_per_att*(natts-1)+posint)=cmsgin(8)
cmo_attlist(number_of_params_per_att*(natts-1)+pospers)=
* cmsgin(9)
cmo_attlist(number_of_params_per_att*(natts-1)+posio)=cmsgin(10)
C
C.... Set up the Memory Managed Arrays for the new Attribute.
C
ctype=cmsgin(5)
clength=cmsgin(7)
crank=cmsgin(6)
lentype=icharlnf(ctype)
C
if(ctype(1:lentype).eq.'VINT') then
C
call cmo_get_info(clength,cmo_name,length,lout,itype,
* ierror_return)
call cmo_get_info(crank,cmo_name,irank,lout,itype,
* ierror_return)
C
mmlength=max(irank*length,1)
C
call mmgetblk(att_name,
* cmo_name,
* ipcmo_pointer,mmlength,
* 1,ier)
idefault=imsgin(11)
if(msgtype(11).eq.2) idefault=nint(xmsgin(11))
C
if(ier.ne.0) then
call cmo_mm_error('cmo_addatt_cmo')
else
do j=1,mmlength
icmo_pointer(j)=idefault
enddo
endif
cmo_attparam_idefault(natts)=idefault
cmo_attparam_rdefault(natts)=idefault
C
elseif(ctype(1:lentype).eq.'VDOUBLE') then
C
call cmo_get_info(clength,cmo_name,length,lout,itype,
* ierror_return)
call cmo_get_info(crank,cmo_name,irank,lout,itype,
* ierror_return)
C
mmlength=max(irank*length,1)
C
call mmgetblk(att_name,
* cmo_name,
* ipcmo_pointer,mmlength,
* 2,ier)
xdefault=xmsgin(11)
if(msgtype(11).eq.1) xdefault=imsgin(11)
C
if(ier.ne.0) then
call cmo_mm_error('cmo_addatt_cmo')
else
do j=1,length*irank
xcmo_pointer(j)=xdefault
enddo
endif
cmo_attparam_rdefault(natts)=xdefault
cmo_attparam_idefault(natts)=nint(xdefault)
c
elseif(ctype(1:lentype).eq.'VCHAR') then
C
call cmo_get_info(clength,cmo_name,length,lout,itype,
* ierror_return)
call cmo_get_info(crank,cmo_name,irank,lout,itype,
* ierror_return)
mmlength=max(irank*length,1)
call mmgetblk(att_name,
* cmo_name,
* ipcmo_pointer,mmlength,
* 3,ier)
cdefault=cmsgin(11)
C
if(ier.ne.0) then
call cmo_mm_error('cmo_addatt_cmo')
else
do j=1,length*irank
ccmo_pointer(j)=cdefault
enddo
endif
cmo_attparam_cdefault(natts)=cdefault
C
elseif(ctype(1:lentype).eq.'INT') then
idefault=imsgin(11)
if(msgtype(11).eq.2) idefault=nint(xmsgin(11))
cmo_attparam_idefault(natts)=idefault
cmo_attparam_rdefault(natts)=idefault
elseif(ctype(1:lentype).eq.'REAL') then
xdefault=xmsgin(11)
if(msgtype(11).eq.1) xdefault=imsgin(11)
cmo_attparam_rdefault(natts)=xdefault
cmo_attparam_idefault(natts)=nint(xdefault)
elseif(ctype(1:lentype).eq.'CHARACTER') then
cmo_attparam_cdefault(natts)=cmsgin(11)
C
C
else
C
C.... Unsupported Type.
C
ierror_return=1
C
write(logmess,9060) cmo_name(1:icharlnf(cmo_name)),
* ctype
call writloga('default',0,logmess,0,ierr)
9060 format('CMO_ADDATT error: Unsupported Type:',a,a)
C
C
endif
C
9998 continue
9999 return
end