OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hm_read_table2_1.F File Reference
#include "implicit_f.inc"
#include "units_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine hm_read_table2_1 (nfunct, ntable1, table, itab, unitab, lsubmodel)

Function/Subroutine Documentation

◆ hm_read_table2_1()

subroutine hm_read_table2_1 ( integer nfunct,
integer ntable1,
type(ttable), dimension(nfunct), intent(inout) table,
integer, intent(inout) itab,
type(unit_type_), intent(in) unitab,
type(submodel_data), dimension(nsubmod), intent(in) lsubmodel )

Definition at line 43 of file hm_read_table2_1.F.

44C-----------------------------------------------
45C M o d u l e s
46C-----------------------------------------------
47 USE table_mod
48 USE message_mod
49 USE submodel_mod
50 USE hm_option_read_mod
51 USE unitab_mod
52 USE names_and_titles_mod , ONLY : nchartitle, ncharfield
53 use simple_checksum_mod
54 use myqsort_d_mod
55C-----------------------------------------------
56C I m p l i c i t T y p e s
57C-----------------------------------------------
58#include "implicit_f.inc"
59C-----------------------------------------------
60C D u m m y A r g u m e n t s
61C-----------------------------------------------
62 integer :: NFUNCT
63 integer :: NTABLE1
64 integer ,intent(inout) :: itab
65 TYPE(SUBMODEL_DATA) ,dimension(NSUBMOD) ,INTENT(IN) :: LSUBMODEL
66 TYPE(TTABLE) ,dimension(NFUNCT) ,INTENT(INOUT) :: TABLE
67 TYPE(UNIT_TYPE_), INTENT(IN) :: UNITAB
68C-----------------------------------------------
69C C o m m o n B l o c k s
70C-----------------------------------------------
71#include "units_c.inc"
72C-----------------------------------------------
73C L o c a l V a r i a b l e s
74C-----------------------------------------------
75 integer :: I,II,K,N,NDIM,sizeh,STAT
76 integer :: ifun,nfun
77 integer :: IDEB,IFIN,IOK
78 integer :: FUNC_ID,TABLE_ID
79 integer :: KK,LL,NN,NF,NP,N1,N11,N12,N13,KK1
80 integer :: i1,i2,countx
81 integer :: ierror,errorstop
82 integer :: nx1,nx2,nx3,nx4,ny
83 integer :: NX(4),NOK(4)
84 my_real :: x0,x1,x2,x3,yy,y1,y2,r,xmin,xmax,scaley
85 my_real :: x234(3)
86 double precision :: h1,h2
87 double precision :: chksum
88 double precision :: hasht(5)
89 double precision ,dimension(:) ,allocatable :: hash
90 integer ,dimension(:) ,allocatable :: jperm1,jperm2
91 integer ,dimension(:) ,allocatable :: idfun,lenx,idxtab
92 integer ,dimension(:) ,allocatable :: nv1,nv2,nv3
93 my_real ,dimension(:) ,allocatable :: xx1,xx2,xx3,xx4,yfac
94 integer ,dimension(:,:) ,allocatable :: itag
95 character(LEN=NCHARTITLE) :: TITR
96 logical :: IS_ENCRYPTED, IS_AVAILABLE
97!===================================================================================================
98 is_encrypted = .false.
99 is_available = .false.
100 CALL hm_option_start('/TABLE/1')
101
102 DO i=1,ntable1
103
104 CALL hm_option_is_encrypted(is_encrypted)
105 CALL hm_option_read_key(lsubmodel, option_titr = titr, option_id = table_id)
106 ! --------------------------------------------------------------------
107
108 CALL hm_get_intv('ORDER', ndim, is_available, lsubmodel)
109 IF (ndim/=1.AND.ndim/=2.AND.ndim/=3.AND.ndim/=4)THEN
110 CALL ancmsg(msgid=777, msgtype=msgerror, anmode=aninfo_blind_1,
111 . i1=ll, c1=titr)
112 END IF
113 nx(:) = 0
114
115 IF (ndim == 1) THEN
116 cycle
117 END IF
118!
119 itab = itab + 1
120 table(itab)%NOTABLE = table_id
121 table(itab)%NDIM = ndim
122 ALLOCATE(table(itab)%X(ndim),stat=stat)
123 IF (stat/=0) CALL ancmsg(msgid=268,anmode=aninfo,msgtype=msgerror,c1='TABLE')
124
125 CALL hm_get_intv('curverows', nfun, is_available, lsubmodel) !number of functions
126 IF (nfun == 1) THEN
127 CALL ancmsg(msgid=778, msgtype=msgerror, anmode=aninfo_blind_1,
128 . i1=table_id, c1=titr, i2=nfun)
129 END IF
130!
131 allocate (idfun(nfun))
132 allocate (idxtab(nfun))
133 allocate (xx2(nfun))
134 allocate (xx3(nfun))
135 allocate (xx4(nfun))
136 allocate (yfac(nfun))
137 allocate (hash(nfun))
138 allocate (lenx(nfun))
139 allocate (jperm2(nfun))
140 allocate (nv1(nfun))
141 allocate (nv2(nfun))
142 allocate (nv3(nfun))
143!
144 ! check function IDs
145 ! count sum of all X abscissa values for all functions
146 nx1 = 0
147 nx2 = 0
148 nx3 = 0
149 nx4 = 0
150 xmin = ep20
151 xmax = -ep20
152 errorstop = 0
153 sizeh = 5
154 idfun(:) = 0
155 k = 0
156 DO ifun = 1,nfun
157 CALL hm_get_int_array_index ('tableentityarray',func_id,ifun,is_available,lsubmodel)
158 CALL hm_get_float_array_index('A' ,x1 ,ifun,is_available,lsubmodel,unitab)
159 CALL hm_get_float_array_index('B' ,x2 ,ifun,is_available,lsubmodel,unitab)
160 CALL hm_get_float_array_index('C' ,x3 ,ifun,is_available,lsubmodel,unitab)
161 CALL hm_get_float_array_index ('Fscale_array' ,scaley ,ifun,is_available,lsubmodel,unitab)
162!
163 DO nf = 1,nfunct
164 IF (table(nf)%NOTABLE == func_id) THEN
165 IF (scaley == zero) scaley = one
166 idfun(ifun) = func_id
167 idxtab(ifun) = nf
168 xx2(ifun) = x1
169 xx3(ifun) = x2
170 xx4(ifun) = x3
171 yfac(ifun) = scaley
172 hasht(1) = func_id
173 hasht(2) = x1
174 hasht(3) = x2
175 hasht(4) = x3
176 hasht(5) = scaley
177 call simple_checksum(hasht,sizeh,chksum)
178 hash(ifun) = chksum
179 lenx(ifun) = SIZE(table(nf)%X(1)%VALUES)
180 nx1 = nx1 + lenx(ifun)
181 EXIT
182 END IF
183 END DO
184!
185 IF (idfun(ifun) == 0) THEN
186 CALL ancmsg(msgid=781, msgtype=msgerror, anmode=aninfo,
187 . i1=table_id, c1=titr, i2=func_id)
188 errorstop = 1
189 END IF
190 nx(1) = nx1
191 ENDDO ! ifun = 1,NFUN
192!-----------------------------------------------------------------------------------------
193! CHECK INPUT ERRORS
194!-----------------------------------------------------------------------------------------
195 ! check duplicated input lines
196!
197 call myqsort_d(nfun,hash,jperm2,ierror)
198 h1 = hash(1)
199 do ifun = 2,nfun
200 h2 = hash(ifun)
201 i1 = jperm2(ifun-1)
202 i2 = jperm2(ifun)
203 if (h1 == h2) then
204 call ancmsg(msgid=3087, msgtype=msgerror, anmode=aninfo,
205 . i1=table_id,c1=titr, i2=idfun(i2))
206 errorstop = 1
207 end if
208 h1 = h2
209 END DO
210!-----------------------------------------------------------------------------------------
211 ! check contradictory data (different funct+scale values for identical abscissa set)
212 sizeh = ndim-1
213 do ifun = 1,nfun
214 hasht(1) = xx2(ifun)
215 hasht(2) = xx3(ifun)
216 hasht(3) = xx4(ifun)
217 call simple_checksum(hasht,sizeh,chksum)
218 hash(ifun) = chksum
219 end do
220 ! hash of all abscissa combinations
221!
222 call myqsort_d(nfun,hash,jperm2,ierror)
223 h1 = hash(1)
224 do ifun = 2,nfun
225 h2 = hash(ifun)
226 i1 = jperm2(ifun-1)
227 i2 = jperm2(ifun)
228 if (h1 == h2 .and. (idfun(i1) /= idfun(i2) .or. yfac(i1) /= yfac(i2))) then
229 call ancmsg(msgid=3088, msgtype=msgerror, anmode=aninfo,
230 . i1=table_id,c1=titr, i2=idfun(i1),r1=yfac(i1),i3=idfun(i2),r2=yfac(i2))
231 errorstop = 1
232 end if
233 h1 = h2
234 end do
235!-----------------------------------------------------------------------------------------
236 ! check if input grid of abscissa values in all dimensons is complete
237!-----------------------------------------------------------------------------------------
238 if (ndim > 1) then
239 call myqsort(nfun,xx2,jperm2,ierror)
240 nx2 = 1
241 nv1(:) = 1
242 do ifun = 2,nfun
243 x2 = xx2(ifun)
244 if (x2 == xx2(nx2)) then
245 nv1(nx2) = nv1(nx2) + 1
246 else if (x2 > xx2(nx2)) then
247 nx2 = nx2 + 1
248 xx2(nx2) = x2
249 end if
250 end do
251 nx(2) = nx2
252 do ifun = 2,nx2
253 if (nv1(ifun) /= nv1(ifun-1)) then
254 CALL ancmsg(msgid=3089, msgtype=msgerror, anmode=aninfo,
255 . i1=table_id,c1=titr)
256 errorstop = 1
257 end if
258 end do
259 end if
260 if (ndim > 2) then
261 call myqsort(nfun,xx3,jperm2,ierror)
262 nx3 = 1
263 nv2(:) = 1
264 do ifun = 2,nfun
265 x2 = xx3(ifun)
266 if (x2 == xx3(nx3)) then
267 nv2(nx3) = nv2(nx3) + 1
268 else if (x2 > xx3(nx3)) then
269 nx3 = nx3 + 1
270 xx3(nx3) = x2
271 end if
272 end do
273 nx(3) = nx3
274 do ifun = 2,nx3
275 if (nv2(ifun) /= nv2(ifun-1)) then
276 CALL ancmsg(msgid=3089, msgtype=msgerror, anmode=aninfo,
277 . i1=table_id,c1=titr)
278 errorstop = 1
279 end if
280 end do
281 end if
282 if (ndim > 3) then
283 call myqsort(nfun,xx4,jperm2,ierror)
284 nx4 = 1
285 nv3(:) = 1
286 do ifun = 2,nfun
287 x2 = xx4(ifun)
288 if (x2 == xx4(nx4)) then
289 nv3(nx4) = nv3(nx4) + 1
290 else if (x2 > xx4(nx4)) then
291 nx4 = nx4 + 1
292 xx4(nx4) = x2
293 end if
294 end do
295 nx(4) = nx4
296 do ifun = 2,nx4
297 if (nv3(ifun) /= nv3(ifun-1)) then
298 CALL ancmsg(msgid=3089, msgtype=msgerror, anmode=aninfo,
299 . i1=table_id,c1=titr)
300 errorstop = 1
301 end if
302 end do
303 end if
304!----------------------------------------------------------------------------
305 !< create common principal abscissa vector for all input functions
306!----------------------------------------------------------------------------
307 allocate (xx1(nx1))
308 allocate (jperm1(nx1))
309!
310 xmin = ep20
311 xmax = -ep20
312 k = 0
313 DO ifun = 1,nfun
314 ii = idxtab(ifun)
315 DO np=1,lenx(ifun)
316 k = k+1
317 xx1(k) = table(ii)%X(1)%VALUES(np)
318 xmin = min(xmin,xx1(k))
319 xmax = max(xmax,xx1(k))
320 END DO
321 END DO !ifun = 1, NFUN
322 !< sort global X abscissa vector
323 call myqsort(nx1,xx1,jperm1,ierror)
324
325 !< save ordered abscissa values, skipping doubles
326 countx = 1
327 x1 = xx1(countx)
328 DO k = 2,nx1
329 x1 = xx1(k)
330 IF (xx1(k) > xx1(countx)) THEN
331 countx = countx+1
332 xx1(countx) = xx1(k)
333 END IF
334 END DO
335 nx1 = countx
336!
337 if (errorstop == 1) return
338!----------------------------------------------------------------------------
339 !< ALLOCATE AND FILL TABLE ABSCISSA AND VALUES
340!----------------------------------------------------------------------------
341 allocate(table(itab)%x(1)%values(nx1),stat=stat)
342 if (stat /= 0) CALL ancmsg(msgid=268,anmode=anstop, msgtype=msgerror)
343 allocate(table(itab)%y,stat=stat)
344 if (stat /= 0) CALL ancmsg(msgid=268,anmode=anstop, msgtype=msgerror)
345 ny = nx1
346
347 table(itab)%x(1)%values(1:nx1) = xx1(1:nx1)
348!
349 if (ndim > 1) then
350 ny = ny * nx2
351 allocate(table(itab)%x(2)%values(nx2))
352 table(itab)%x(2)%values(1:nx2) = xx2(1:nx2)
353 end if
354 if (ndim > 2) then
355 ny = ny * nx3
356 allocate(table(itab)%x(3)%values(nx3))
357 table(itab)%x(3)%values(1:nx3) = xx3(1:nx3)
358 end if
359 if (ndim > 3) then
360 ny = ny * nx4
361 allocate(table(itab)%x(4)%values(nx4))
362 table(itab)%x(4)%values(1:nx4) = xx4(1:nx4)
363 end if
364!
365 allocate(table(itab)%y%values(ny),stat=stat)
366 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo, msgtype=msgerror, c1='TABLE')
367!-----------------------------------------------------------------------------------------
368 !< Calculate table values for full grid of abscissa in all directions
369!-----------------------------------------------------------------------------------------
370 ALLOCATE(itag(nx1,nx2*max(1,nx3)*max(1,nx4)), stat=stat)
371 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo, msgtype=msgerror, c1='ITAG')
372 itag(:,:) = 0
373 nx(1) = nx1
374 nx(2) = nx2
375 nx(3) = nx3
376 nx(4) = nx4
377!
378 DO ifun = 1, nfun
379 CALL hm_get_int_array_index ('tableentityarray',func_id,ifun,is_available,lsubmodel)
380 CALL hm_get_float_array_index ('A' ,x234(1),ifun,is_available,lsubmodel,unitab)
381 CALL hm_get_float_array_index ('B' ,x234(2),ifun,is_available,lsubmodel,unitab)
382 CALL hm_get_float_array_index ('C' ,x234(3),ifun,is_available,lsubmodel,unitab)
383 CALL hm_get_float_array_index ('Fscale_array' ,scaley ,ifun,is_available,lsubmodel,unitab)
384!
385 IF (scaley == zero) scaley = one
386 nok=0
387 DO n=2,ndim
388 ideb=1
389 ifin=nx(n)
390 iok=0
391 DO WHILE(iok==0)
392 IF(ifin-ideb==1)THEN
393 k=ideb
394 IF (table(itab)%X(n)%VALUES(k)==x234(n-1)) THEN
395 ELSE
396 k=k+1
397 END IF
398 iok=1
399 ELSE
400 k=(ideb+ifin)/2
401 IF(table(itab)%X(n)%VALUES(k) > x234(n-1))THEN
402 ifin=k
403 ELSEIF(table(itab)%X(n)%VALUES(k) < x234(n-1))THEN
404 ideb=k
405 ELSE
406 iok=1
407 END IF
408 END IF
409 nok(n)=k
410 END DO
411 END DO
412!
413 DO nf=1,nfunct
414 IF(table(nf)%NOTABLE==func_id)THEN
415 nok(1)=1
416 DO np=1,SIZE(table(nf)%X(1)%VALUES)
417 x1=table(nf)%X(1)%VALUES(np)
418 DO WHILE(x1 > table(itab)%X(1)%VALUES(nok(1)))
419 nok(1)=nok(1)+1
420 END DO
421 nn=1
422 kk=nok(1)
423 DO n=2,ndim
424 nn=nn*nx(n-1)
425 kk=nn*(nok(n)-1)+kk
426 END DO
427 table(itab)%Y%VALUES(kk)=table(nf)%Y%VALUES(np)*scaley
428 kk = max(1,nx(3))*nx(2)*(max(1,nok(4))-1) + nx(2)*(max(1,nok(3))-1) + nok(2)
429 itag(nok(1),kk)=1
430 END DO
431 EXIT
432 END IF
433 END DO
434 END DO ! ifun = 1, NFUN
435C-------------------------------------------------------------------------------
436C interpolation
437 DO kk=1,nx(2)*max(1,nx(3))*max(1,nx(4))
438 n11=1
439 DO WHILE(itag(n11,kk)==0)
440 n11=n11+1
441 END DO
442 n12=n11+1
443 DO WHILE(itag(n12,kk)==0)
444 n12=n12+1
445 IF(n12 > nx1)THEN
446c error (function 1 pt)
447 END IF
448 END DO
449 x1=table(itab)%X(1)%VALUES(n11)
450 x2=table(itab)%X(1)%VALUES(n12)
451 kk1=nx1*(kk-1)+n11
452 y1=table(itab)%Y%VALUES(kk1)
453 kk1=nx1*(kk-1)+n12
454 y2=table(itab)%Y%VALUES(kk1)
455 DO n1=1,n12
456 IF(n1/=n11) THEN
457 x0=table(itab)%X(1)%VALUES(n1)
458 r=(x2-x0)/(x2-x1)
459 yy=r*y1+(one-r)*y2
460 kk1=nx1*(kk-1)+n1
461 table(itab)%Y%VALUES(kk1)=yy
462 itag(n1,kk)=1
463 END IF
464 END DO
465 200 CONTINUE
466 n13=n12+1
467 DO WHILE(n13 <= nx1)
468 IF (itag(n13,kk) == 0) THEN
469 n13=n13+1
470 ELSE
471 EXIT
472 ENDIF
473 END DO
474 IF(n13 > nx1)THEN
475 x1=table(itab)%X(1)%VALUES(n11)
476 x2=table(itab)%X(1)%VALUES(n12)
477 kk1=nx1*(kk-1)+n11
478 y1=table(itab)%Y%VALUES(kk1)
479 kk1=nx1*(kk-1)+n12
480 y2=table(itab)%Y%VALUES(kk1)
481 DO n1=n12+1,nx1
482 x0=table(itab)%X(1)%VALUES(n1)
483 r=(x2-x0)/(x2-x1)
484 yy=r*y1+(one-r)*y2
485 kk1=nx1*(kk-1)+n1
486 table(itab)%Y%VALUES(kk1)=yy
487 itag(n1,kk)=1
488 END DO
489 ELSE
490 n11=n12
491 n12=n13
492 IF(n12 > n11+1)THEN
493 x1=table(itab)%X(1)%VALUES(n11)
494 x2=table(itab)%X(1)%VALUES(n12)
495 kk1=nx1*(kk-1)+n11
496 y1=table(itab)%Y%VALUES(kk1)
497 kk1=nx1*(kk-1)+n12
498 y2=table(itab)%Y%VALUES(kk1)
499 DO n1=n11+1,n12-1
500 x0=table(itab)%X(1)%VALUES(n1)
501 r=(x2-x0)/(x2-x1)
502 yy=r*y1+(one-r)*y2
503 kk1=nx1*(kk-1)+n1
504 table(itab)%Y%VALUES(kk1)=yy
505 itag(n1,kk)=1
506 END DO
507 END IF
508 GO TO 200
509 END IF
510 END DO ! KK
511!-----------------------------------------------------------------------------------------
512 deallocate(itag)
513 deallocate (xx1)
514 deallocate (xx2)
515 deallocate (xx3)
516 deallocate (xx4)
517 deallocate (hash)
518 deallocate (lenx)
519 deallocate (yfac)
520 deallocate (jperm1)
521 deallocate (jperm2)
522 deallocate (nv1)
523 deallocate (nv2)
524 deallocate (nv3)
525 deallocate (idxtab)
526 deallocate (idfun)
527!-----------------------------------------------------------------
528! OUTPUT OF TABLE VALUES
529!-----------------------------------------------------------------
530 ny=SIZE(table(itab)%Y%VALUES)
531 IF (is_encrypted)THEN
532 WRITE(iout,'(A)')'CONFIDENTIAL DATA'
533 ELSE
534 WRITE(iout,2000) ntable1
535 WRITE(iout,2100) table(itab)%NOTABLE, table(itab)%NDIM
536 DO k=1,table(itab)%NDIM
537 nx(k) = SIZE(table(itab)%X(k)%VALUES)
538 WRITE(iout,2200) k
539 WRITE(iout,2250) (table(itab)%X(k)%VALUES(n),n=1,nx(k))
540 END DO
541 ny = SIZE(table(itab)%Y%VALUES)
542 WRITE(iout,2300)
543 WRITE(iout,2350) (table(itab)%Y%VALUES(n),n=1,ny)
544 END IF
545
546 END DO ! NTABLE1
547!
548 RETURN
549!-----------------------------------------------------------------
5502000 FORMAT(//
551 . ' TABLES'/
552 . ' ------'/
553 . ' NUMBER OF TABLES . . . . . . . . . . =',i10/)
5542100 FORMAT(/' TABLE ID . . . . . . . . . . . . . . =',i10/
555 . ' NUMBER OF PARAMETERS . . . . . . . . =',i10/)
5562200 FORMAT(/' VALUES FOR PARAMETER NUMBER. . . . . .',i4,':'/)
5572250 FORMAT((3x,5(1x,g20.13))/)
5582300 FORMAT(/' ORDINATE VALUES . . . . . . . . . . . :'/)
5592350 FORMAT((3x,5(1x,g20.13))/)
560C-----------------------------------------------------------------
my_real
#define my_real
Definition cppsort.cpp:32
hm_get_float_array_index
subroutine hm_get_float_array_index(name, rval, index, is_available, lsubmodel, unitab)
Definition hm_get_float_array_index.F:105
hm_get_int_array_index
subroutine hm_get_int_array_index(name, ival, index, is_available, lsubmodel)
Definition hm_get_int_array_index.F:164
hm_get_intv
subroutine hm_get_intv(name, ival, is_available, lsubmodel)
Definition hm_get_intv.F:523
hm_option_is_encrypted
subroutine hm_option_is_encrypted(is_encrypted)
Definition hm_option_is_encrypted.F:284
hm_option_start
subroutine hm_option_start(entity_type)
Definition hm_option_start.F:251
hm_option_read_mod::hm_option_read_key
Definition hm_option_read_mod.F:410
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
myqsort
subroutine myqsort(n, a, perm, error)
Definition myqsort.F:51
hm_option_read_mod
Definition hm_option_read_mod.F:408
message_mod
Definition message_mod.F:1249
names_and_titles_mod
Definition names_and_titles_mod.F:997
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1003
names_and_titles_mod::ncharfield
integer, parameter ncharfield
Definition names_and_titles_mod.F:1005
submodel_mod
Definition submodel_mod.F:712
table_mod
Definition table_mod.F:112
unitab_mod
Definition unitab_mod.F:513
simple_checksum
void simple_checksum(const double *vector, const int *length, double *hash)
Definition simple_checksum.cpp:43
ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:889