53 use simple_checksum_mod
58#include "implicit_f.inc"
64 integer ,
intent(inout) :: itab
65 TYPE(
submodel_data) ,
dimension(NSUBMOD) ,
INTENT(IN) :: LSUBMODEL
66 TYPE(
ttable) ,
dimension(NFUNCT) ,
INTENT(INOUT) :: TABLE
75 integer :: I,II,K,N,NDIM,sizeh,STAT
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
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
98 is_encrypted = .false.
99 is_available = .false.
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,
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')
125 CALL hm_get_intv(
'curverows', nfun, is_available, lsubmodel)
127 CALL ancmsg(msgid=778, msgtype=msgerror, anmode=aninfo_blind_1,
128 . i1=table_id, c1=titr, i2=nfun)
131 allocate (idfun(nfun))
132 allocate (idxtab(nfun))
136 allocate (yfac(nfun))
137 allocate (hash(nfun))
138 allocate (lenx(nfun))
139 allocate (jperm2(nfun))
164 IF (table(nf)%NOTABLE == func_id)
THEN
165 IF (scaley == zero) scaley = one
166 idfun(ifun) = func_id
179 lenx(ifun) =
SIZE(table(nf)%X(1)%VALUES)
180 nx1 = nx1 + lenx(ifun)
185 IF (idfun(ifun) == 0)
THEN
186 CALL ancmsg(msgid=781, msgtype=msgerror, anmode=aninfo,
187 . i1=table_id, c1=titr, i2=func_id)
197 call myqsort_d(nfun,hash,jperm2,ierror)
204 call ancmsg(msgid=3087, msgtype=msgerror, anmode=aninfo,
205 . i1=table_id,c1=titr, i2=idfun(i2))
222 call myqsort_d(nfun,hash,jperm2,ierror)
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))
239 call myqsort(nfun,xx2,jperm2,ierror)
244 if (x2 == xx2(nx2))
then
245 nv1(nx2) = nv1(nx2) + 1
246 else if (x2 > xx2(nx2))
then
253 if (nv1(ifun) /= nv1(ifun-1))
then
254 CALL ancmsg(msgid=3089, msgtype=msgerror, anmode=aninfo,
255 . i1=table_id,c1=titr)
261 call myqsort(nfun,xx3,jperm2,ierror)
266 if (x2 == xx3(nx3))
then
267 nv2(nx3) = nv2(nx3) + 1
268 else if (x2 > xx3(nx3))
then
275 if (nv2(ifun) /= nv2(ifun-1))
then
276 CALL ancmsg(msgid=3089, msgtype=msgerror, anmode=aninfo,
277 . i1=table_id,c1=titr)
283 call myqsort(nfun,xx4,jperm2,ierror)
288 if (x2 == xx4(nx4))
then
289 nv3(nx4) = nv3(nx4) + 1
290 else if (x2 > xx4(nx4))
then
297 if (nv3(ifun) /= nv3(ifun-1))
then
298 CALL ancmsg(msgid=3089, msgtype=msgerror, anmode=aninfo,
299 . i1=table_id,c1=titr)
308 allocate (jperm1(nx1))
317 xx1(k) = table(ii)%X(1)%VALUES(np)
318 xmin =
min(xmin,xx1(k))
319 xmax =
max(xmax,xx1(k))
323 call myqsort(nx1,xx1,jperm1,ierror)
330 IF (xx1(k) > xx1(countx))
THEN
337 if (errorstop == 1)
return
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)
347 table(itab)%x(1)%values(1:nx1) = xx1(1:nx1)
351 allocate(table(itab)%x(2)%values(nx2))
352 table(itab)%x(2)%values(1:nx2) = xx2(1:nx2)
356 allocate(table(itab)%x(3)%values(nx3))
357 table(itab)%x(3)%values(1:nx3) = xx3(1:nx3)
361 allocate(table(itab)%x(4)%values(nx4))
362 table(itab)%x(4)%values(1:nx4) = xx4(1:nx4)
365 allocate(table(itab)%y%values(ny),stat=stat)
366 IF (stat /= 0)
CALL ancmsg(msgid=268,anmode=aninfo, msgtype=msgerror, c1=
'TABLE')
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')
385 IF (scaley == zero) scaley = one
394 IF (table(itab)%X(n)%VALUES(k)==x234(n-1))
THEN
401 IF(table(itab)%X(n)%VALUES(k) > x234(n-1))
THEN
403 ELSEIF(table(itab)%X(n)%VALUES(k) < x234(n-1))
THEN
414 IF(table(nf)%NOTABLE==func_id)
THEN
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)))
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)
437 DO kk=1,nx(2)*
max(1,nx(3))*
max(1,nx(4))
439 DO WHILE(itag(n11,kk)==0)
443 DO WHILE(itag(n12,kk)==0)
449 x1=table(itab)%X(1)%VALUES(n11)
450 x2=table(itab)%X(1)%VALUES(n12)
452 y1=table(itab)%Y%VALUES(kk1)
454 y2=table(itab)%Y%VALUES(kk1)
457 x0=table(itab)%X(1)%VALUES(n1)
461 table(itab)%Y%VALUES(kk1)=yy
468 IF (itag(n13,kk) == 0)
THEN
475 x1=table(itab)%X(1)%VALUES(n11)
476 x2=table(itab)%X(1)%VALUES(n12)
478 y1=table(itab)%Y%VALUES(kk1)
480 y2=table(itab)%Y%VALUES(kk1)
482 x0=table(itab)%X(1)%VALUES(n1)
486 table(itab)%Y%VALUES(kk1)=yy
493 x1=table(itab)%X(1)%VALUES(n11)
494 x2=table(itab)%X(1)%VALUES(n12)
496 y1=table(itab)%Y%VALUES(kk1)
498 y2=table(itab)%Y%VALUES(kk1)
500 x0=table(itab)%X(1)%VALUES(n1)
504 table(itab)%Y%VALUES(kk1)=yy
530 ny=
SIZE(table(itab)%Y%VALUES)
531 IF (is_encrypted)
THEN
532 WRITE(iout,
'(A)')
'CONFIDENTIAL DATA'
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)
539 WRITE(iout,2250) (table(itab)%X(k)%VALUES(n),n=1,nx(k))
541 ny =
SIZE(table(itab)%Y%VALUES)
543 WRITE(iout,2350) (table(itab)%Y%VALUES(n),n=1,ny)
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))/)
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)