OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
fsdcod.F
Go to the documentation of this file.
1Copyright> OpenRadioss
2Copyright> Copyright (C) 1986-2025 Altair Engineering Inc.
3Copyright>
4Copyright> This program is free software: you can redistribute it and/or modify
5Copyright> it under the terms of the GNU Affero General Public License as published by
6Copyright> the Free Software Foundation, either version 3 of the License, or
7Copyright> (at your option) any later version.
8Copyright>
9Copyright> This program is distributed in the hope that it will be useful,
10Copyright> but WITHOUT ANY WARRANTY; without even the implied warranty of
11Copyright> MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12Copyright> GNU Affero General Public License for more details.
13Copyright>
14Copyright> You should have received a copy of the GNU Affero General Public License
15Copyright> along with this program. If not, see <https://www.gnu.org/licenses/>.
16Copyright>
17Copyright>
18Copyright> Commercial Alternative: Altair Radioss Software
19Copyright>
20Copyright> As an alternative to this open-source version, Altair also offers Altair Radioss
21Copyright> software under a commercial license. Contact Altair to discuss further if the
22Copyright> commercial version may interest you: https://www.altair.com/radioss/.
23!||====================================================================
24!|| fsdcod ../starter/source/system/fsdcod.F
25!||--- called by ------------------------------------------------------
26!|| lectur ../starter/source/starter/lectur.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../starter/source/output/message/message.F
29!|| fretitl2 ../starter/source/starter/freform.F
30!|| iniguser ../starter/source/system/iniguser.F
31!|| nintri ../starter/source/system/nintrr.F
32!|| usr2sys ../starter/source/system/sysfus.F
33!||--- uses -----------------------------------------------------
34!|| intstamp_mod ../starter/share/modules1/intstamp_mod.F
35!|| message_mod ../starter/share/message_module/message_mod.F
36!|| table_mod ../starter/share/modules1/table_mod.F
37!||====================================================================
38 SUBROUTINE fsdcod(PYTHON, BUFMAT ,PM ,GEO ,IBCL ,IPRES ,
39 . IBFV ,ISKEW ,ISKN ,SENSORS ,MAT_PARAM,
40 . ITABM1 ,SKEW ,LACCELM ,INSEL ,BUFGEO ,
41 . IBCSLAG ,IGEO ,IPM ,
42 . IBFT ,IBCV ,IBFVEL ,
43 . IBCR ,TABLE ,NPC1 ,NPC ,PLD ,
44 . NOM_OPT ,IBFFLUX ,GLOB_THERM,NIMPVEL ,NIMPDISP ,
45 . NIMPACC)
46C-----------------------------------------------
47C D e s c r i p t i o n
48C-----------------------------------------------C
49C CONVERTING USER IDENTIFIER INTO INTERNAL IDENTIFIERS (/SKEW, /FUNCT, /TABLE, /SENSOR, ...)
50C user_funct_id -> [1, NFUNCT]
51C user_skew_id -> [1, NSKEW]
52C ...
53C-----------------------------------------------
54C M o d u l e s
55C-----------------------------------------------
56 USE python_funct_mod, only : python_
57 USE message_mod
58 USE intstamp_mod
59 USE table_mod
60 USE sensor_mod
61 USE names_and_titles_mod , ONLY : nchartitle
62 USE matparam_def_mod, ONLY : matparam_struct_
63 use glob_therm_mod
64C-----------------------------------------------
65C I m p l i c i t T y p e s
66C-----------------------------------------------
67#include "implicit_f.inc"
68C-----------------------------------------------
69C C o m m o n B l o c k s
70C-----------------------------------------------
71#include "com04_c.inc"
72#include "param_c.inc"
73#include "scr03_c.inc"
74#include "scr17_c.inc"
75C-----------------------------------------------
76C D u m m y A r g u m e n t s
77C-----------------------------------------------
78 TYPE(python_), INTENT(IN) :: PYTHON
79 TYPE(glob_therm_) ,intent(in) :: glob_therm
80 INTEGER IBFV(NIFV,*),NPC(*), NPC1(*), IBCL(NIBCLD,*), IPRES(NIBCLD,*),
81 . ISKEW(*), ISKN(LISKN,*), ITABM1(*),
82 . LACCELM(3,*),INSEL(*),IBCSLAG(5,*),
83 . IPM(NPROPMI,NUMMAT), IGEO(NPROPGI,NUMGEO),IBCV(GLOB_THERM%NICONV,*),
84 . IBCR(GLOB_THERM%NIRADIA,*),IBFFLUX(GLOB_THERM%NITFLUX,*)
85 INTEGER ,DIMENSION(NIFV,NFXVEL) ,INTENT(INOUT) :: IBFVEL
86 INTEGER, INTENT(IN) :: NIMPVEL, NIMPDISP, NIMPACC
87 INTEGER ,DIMENSION(GLOB_THERM%NIFT,GLOB_THERM%NFXTEMP) ,INTENT(INOUT) :: IBFT
88 my_real PM(NPROPM,NUMMAT), GEO(NPROPG,NUMGEO),SKEW(LSKEW,*), PLD(*),BUFMAT(*)
89 TYPE(TTABLE) , DIMENSION(NTABLE) :: TABLE
90 DOUBLE PRECISION BUFGEO(*)
91 INTEGER NOM_OPT(LNOPT1,*)
92 TYPE (SENSORS_) ,INTENT(IN) :: SENSORS
93 TYPE(matparam_struct_) ,DIMENSION(NUMMAT) ,INTENT(INOUT) :: MAT_PARAM
94C-----------------------------------------------
95C L o c a l V a r i a b l e s
96C-----------------------------------------------
97 INTEGER ISERV(18), IFLAG1, IFLAG2, IFLAG3, I,II,ILAW,J,JJ,K,I1,
98 . is,igtyp,nf,noskew,nd,iun,ifail,iadd,nfunc,nfund,iexpan,ifunc,
99 . ierr1,ierr2,ip,ir, kdir, icond, ifunct, ok, itable,
100 . isk,ifc,ifd,ic1,ic2,id1,id2,nmual,nogd,nc,iflag,itens,
101 . ichk, iflag0, ni,efunc,ie,ie2,ife,nrate,errf,h,np1,np2,j1,k1,
102 . load,unload, nty,idn,idt,pn1,pn2,pt1,pt2,kk,
103 . ifric1,ifric2,idamp1,idamp2,load0,unload0,nf2,func,fund,iok,isens,imat,ieos,
104 . a_func, b_func
105 LOGICAL IS_FOUND
106
107 INTEGER NINTRI
108
109 my_real
110 . PUN,X0,DX,DY,DERI,E,G,MUAL(10),MU,GS,RBULK,EMAX,GMAX,E0,EPSMAX,
111 . YFAC,DERI0,X1,EPS0,EPST1,EPST2,Y0,Y1,DYDX,DTDS,FAC(6),FAC1,FAC2,
112 . s1,s2,t1,t2,xx1,x2,yy1,y2,sx,ty,xscale,alpha1,alpha2,
113 . stiff,stiff0,kc,kt,nu,young,derik(20),x_scale
114 my_real
115 . , DIMENSION(:), ALLOCATABLE :: stress,stretch
116 INTEGER ID
117 CHARACTER(LEN=NCHARTITLE) :: TITR
118 CHARACTER*40 MESS
119 CHARACTER*80 MESS1
120 DATA IUN/1/
121
122! ICHECK - checking level in LAW69 curve fitting
123! <=0 no validity checking of mu_i and alpha_i in curve
124! fitting
125! 1 SUM( mu(i) * alpha(i) ) > 0.0
126! 2 mu(i) * alpha(i) > 0.0
127! 3 Try ICHECK=2 at first, if fails, switch to ICHECK=1 and try again.
128 INTEGER ICHECK
129 INTEGER NSTART
130! ERRTOL - Tolerance for convergence checking in LAW69 curve fitting
131! If ERRAVE < ERRTOL, data fitting converges.
132! ERRAVE = ( SUM [ ABS ( ( Y_inp-Y_fit) / Y_inp ) ) / NPT
133 my_real ERRTOL
134C-----------------------------------------------
135C E x t e r n a l F u n c t i o n s
136C-----------------------------------------------
137 INTEGER USR2SYS
138C
139 DATA MESS/'11TH MATERIAL LAW DEFINITION '/
140 DATA pun/0.1/
141C-----------------------------------------------
142C S o u r c e L i n e s
143C-----------------------------------------------
144 iflag1=0
145 iflag2=0
146 nf=0
147C----------------------------
148C (I) FUNCTIONS (/FUNCT)
149C----------------------------
150C
151C
152 15 CONTINUE
153C
154C 2) MATERIAL LAWS 11 18 20 21 28-31
155C
156 DO 300 i=1,nummat
157C
158 id=ipm(1,i)
159 CALL fretitl2(titr,ipm(npropmi-ltitr+1,i),ltitr)
160 ilaw=ipm(2,i)
161C
162 IF(ilaw == 11) THEN
163C
164C UPDATING NODE IDENTIFIER
165 IF(nint(pm(51,i))/=0)THEN
166 pm(51,i) = usr2sys(nint(pm(51,i)),itabm1,mess,id)+pun
167 ENDIF
168C
169 DO j=1,10
170 iserv(j)=ipm(10+j,i)
171 enddo!next J
172 DO 230 k=1,10
173 IF(iserv(k)/=0) THEN
174 DO j=1,nfunct
175 IF(iserv(k) == npc1(j)) THEN
176 ipm(10+k,i)=j
177
178 !check density function : IPM(11)
179 IF(k == 1)THEN
180 ic1 = npc(j)
181 ic2 = npc(j+1)
182 jj=0
183 DO ii = ic1,ic2-2,2
184 jj = jj+1
185 y0 = pld(ii+1)
186 IF(y0 <= zero)THEN
187 CALL ancmsg(msgid=132,msgtype=msgerror,anmode=aninfo,
188 . i1=id, i2=iserv(k), i3=jj,
189 . c1=titr,
190 . r1=y0)
191 EXIT
192 ENDIF
193 ENDDO
194 ENDIF ! !end check
195
196 GOTO 230
197 ENDIF
198 enddo!next J
199 ipm(10+k,i) = 0 !function does not exist. Avoid check bounds issues
200 CALL ancmsg(msgid=126,msgtype=msgerror,anmode=aninfo_blind_1,
201 . i1=id,
202 . c1=titr,
203 . i2=iserv(k))
204 ENDIF
205 230 CONTINUE
206C
207 ELSE IF(ilaw == 18) THEN
208 nf=ipm(10,i)
209 DO 250 k=1,nf
210 is=ipm(10+k,i)
211 IF(is/=0)THEN
212 DO j=1,nfunct
213 IF(is == npc1(j)) THEN
214 ipm(10+k,i)=j
215 GOTO 250
216 ENDIF
217 ENDDO
218 CALL ancmsg(msgid=126,
219 . msgtype=msgerror,
220 . anmode=aninfo_blind_1,
221 . i1=id,
222 . c1=titr,
223 . i2=is)
224 ENDIF
225 250 CONTINUE
226c
227 ELSE IF(ilaw == 21) THEN
228C
229 is=ipm(11,i)
230 IF(is/=0) THEN
231 DO 260 j=1,nfunct
232 IF(is == npc1(j)) THEN
233 ipm(11,i)=j
234 GOTO 183
235 ENDIF
236 260 CONTINUE
237 ENDIF
238 CALL ancmsg(msgid=126,
239 . msgtype=msgerror,
240 . anmode=aninfo_blind_1,
241 . i1=id,
242 . c1=titr,
243 . i2=is)
244C
245C-------
246 ELSE IF(ilaw == 43) THEN
247 efunc = 0
248 nf=ipm(10,i)
249 IF(ipm(10+nf,i) /= 0)efunc=1
250 DO 243 k=1,nf
251 is=ipm(10+k,i)
252 IF(is/=0)THEN
253 DO j=1,nfunct
254 IF(is == npc1(j)) THEN
255 ipm(10+k,i)=j
256 GOTO 243
257 ENDIF
258 ENDDO
259 CALL ancmsg(msgid=126,
260 . msgtype=msgerror,
261 . anmode=aninfo_blind_1,
262 . i1=id,
263 . c1=titr,
264 . i2=is)
265 ENDIF
266 243 CONTINUE
267 IF (efunc > 0) THEN
268 ife=ipm(10+nf,i)
269 IF(nf > efunc)THEN
270 ie =npc(ife)
271 ie2=npc(ife+1)
272 DO ii = ie+1,ie2-3,2
273 IF(pld(ii) < pld(ii+2))THEN
274 CALL ancmsg(msgid=975,
275 . msgtype=msgerror,
276 . anmode=aninfo,
277 . i1=id,
278 . c1=titr)
279 EXIT
280 ENDIF
281 ENDDO
282 ENDIF
283 ENDIF
284C law 52
285 ELSE IF (ilaw == 52) THEN
286 DO 52 k = 1,ipm(226,i)!NTABLE
287 itable = ipm(226+k,i)
288 IF(itable/=0)THEN
289 DO j=1,ntable
290 IF(itable == table(j)%NOTABLE) THEN
291 ipm(226+k,i)=j
292 itable=ipm(226+k,i)
293 GOTO 52
294 ENDIF
295 END DO
296 CALL ancmsg(msgid=779,
297 . msgtype=msgerror,
298 . anmode=aninfo,
299 . i1=id,
300 . c1=titr,
301 . i2=itable)
302 ENDIF
303 52 CONTINUE
304c------------------------
305C
306 ELSE IF(ilaw == 59) THEN
307 nf = ipm(10,i)
308 DO 280 k=1,nf
309 is = ipm(10+k,i)
310 IF (is /= 0) THEN
311 DO j=1,nfunct
312 IF(is == npc1(j)) THEN
313 ipm(10+k,i)=j
314 GOTO 280
315 ENDIF
316 ENDDO
317 CALL ancmsg(msgid=126,
318 . msgtype=msgerror,
319 . anmode=aninfo_blind_1,
320 . i1=id,
321 . c1=titr,
322 . i2=is)
323 ENDIF
324 280 CONTINUE
325c
326 IF (nf > 0)THEN
327 iadd = ipm(7,i) - 1
328 e = bufmat(iadd+1)
329 g = bufmat(iadd+2)
330 nrate = bufmat(iadd+3)
331 emax = zero
332 gmax = zero
333 DO k=1,2*nrate-1,2
334 idn = ipm(10+k,i)
335 idt = ipm(10+k+1,i)
336 pn1 = npc(idn)
337 pn2 = npc(idn+1)
338 pt1 = npc(idt)
339 pt2 = npc(idt+1)
340 kk = (k+1)/2
341 yfac= bufmat(iadd+7+kk)
342 DO jj = pn1,pn2-4,2
343 dx = pld(jj+2) - pld(jj)
344 dy = pld(jj+3) - pld(jj+1)
345 deri = abs(dy*yfac / dx)
346 emax = max(emax, deri)
347 ENDDO
348 DO jj = pt1,pt2-4,2
349 dx = pld(jj+2) - pld(jj)
350 dy = pld(jj+3) - pld(jj+1)
351 deri = abs(dy*yfac / dx)
352 gmax = max(gmax, deri)
353 ENDDO
354 ENDDO
355 IF (emax > e) THEN
356 bufmat(iadd+1) = emax
357 CALL ancmsg(msgid= 1041,
358 . msgtype=msgwarning,
359 . anmode=aninfo,
360 . i1=id,
361 . c1=titr,c2='YOUNG MODULUS',r1=emax)
362 ENDIF
363 IF (gmax > g) THEN
364 bufmat(iadd+2) = gmax
365 CALL ancmsg(msgid= 1041,
366 . msgtype=msgwarning,
367 . anmode=aninfo,
368 . i1=id,
369 . c1=titr,c2='SHEAR MODULUS',r1=gmax)
370 ENDIF
371 ENDIF
372
373C
374 ELSE IF(ilaw == 60) THEN
375 efunc = 0
376 nf=ipm(10,i)
377 IF(ipm(10+nf,i) /= 0)THEN
378 efunc=1
379 IF(ipm(10+nf-1,i) /= 0 ) efunc =2
380 ENDIF
381 DO 287 k=1,nf
382 is=ipm(10+k,i)
383 IF(is/=0)THEN
384 DO j=1,nfunct
385 IF(is == npc1(j)) THEN
386 ipm(10+k,i)=j
387 GOTO 287
388 ENDIF
389 ENDDO
390 CALL ancmsg(msgid=126,
391 . msgtype=msgerror,
392 . anmode=aninfo_blind_1,
393 . i1=id,
394 . c1=titr,
395 . i2=is)
396 ENDIF
397 287 CONTINUE
398 IF (efunc > 0) THEN
399 ife=ipm(10+nf,i)
400 IF(nf > efunc)THEN
401 ie =npc(ife)
402 ie2=npc(ife+1)
403 DO ii = ie+1,ie2-3,2
404 IF(pld(ii) < pld(ii+2))THEN
405 CALL ancmsg(msgid=975,
406 . msgtype=msgerror,
407 . anmode=aninfo,
408 . i1=id,
409 . c1=titr)
410 EXIT
411 ENDIF
412 ENDDO
413 ENDIF
414 ENDIF
415C-------------------------------
416 ELSE IF (ilaw == 65) THEN
417 nf = ipm(10,i)
418 DO 296 k=1,nf
419 is = ipm(10+k,i)
420 IF (is /=0)THEN
421 DO j=1,nfunct
422 IF(is == npc1(j)) THEN
423 ipm(10+k,i)=j
424 GOTO 296
425 ENDIF
426 ENDDO
427 CALL ancmsg(msgid=126,
428 . msgtype=msgerror,
429 . anmode=aninfo_blind_1,
430 . i1=id,
431 . c1=titr,
432 . i2=is)
433 ENDIF
434 296 CONTINUE
435C
436 IF (nf > 0) THEN
437 iadd = ipm(7,i) - 1
438 nrate= bufmat(iadd+1)
439 e = bufmat(iadd+2)
440 g = bufmat(iadd+8)
441
442c DO K=1,NF-1,2
443 DO k=1,nrate
444 ifc = ipm(10+k,i)
445 ifd = ipm(10+k+nrate,i)
446 yfac=bufmat(iadd+14+nrate+k)
447 IF (ifc > 0 .AND. ifd > 0) THEN
448 ic1 = npc(ifc)
449 ic2 = npc(ifc+1)
450 id1 = npc(ifd)
451 id2 = npc(ifd+1)
452 ierr1 = 0
453 ierr2 = 0
454C loading function
455 x0 = pld(ic1)
456 DO ii = ic1,ic2-4,2
457 jj = ii+2
458 dx = pld(jj) - x0
459 dy = pld(jj+1) - pld(ii+1)
460 deri = dy*yfac / dx
461 dx = dx*(e - deri)/e
462 x0 = pld(jj)
463 IF (dx < zero) ierr1 = 1
464c PLD(JJ) = PLD(II) + DX
465 ENDDO
466c unloading function
467 x0 = pld(id1)
468 DO ii = id1,id2-4,2
469 jj = ii+2
470 dx = pld(jj) - x0
471 dy = pld(jj+1) - pld(ii+1)
472 deri = dy *yfac/ dx
473 dx = dx*(e - deri)/e
474 IF (dx < zero) ierr2 = 1
475 x0 = pld(jj)
476c PLD(JJ) = PLD(II) + DX
477 ENDDO
478 IF (ierr1 == 1) THEN
479 CALL ancmsg(msgid=808,
480 . msgtype=msgerror,
481 . anmode=aninfo_blind_1,
482 . i1=id,
483 . c1=titr,
484 . i2=npc1(ifc))
485 ENDIF
486 IF (ierr2 == 1) THEN
487 CALL ancmsg(msgid=808,
488 . msgtype=msgerror,
489 . anmode=aninfo_blind_1,
490 . i1=id,
491 . c1=titr,
492 . i2=npc1(ifd))
493 ENDIF
494 ENDIF
495 ENDDO
496 ENDIF
497C
498 ELSE IF (ilaw == 75) THEN
499C CHANGE USER MATERIAL NUMBER TO INTERNAL
500 iadd = ipm(7,i)-1
501 ii = nint(bufmat(iadd+6))
502 jj = nintri(ii,ipm,npropmi,nummat,1)
503 bufmat(iadd+6) = jj
504 IF(jj == 0) THEN
505 CALL ancmsg(msgid=1008,
506 . msgtype=msgerror,
507 . anmode=aninfo,
508 . i1=id,i2=ii,
509 . c1=titr)
510 ENDIF
511C
512 ELSE IF (ilaw == 78) THEN
513 nf = ipm(10,i)
514 DO 378 k=1,nf
515 is = ipm(10+k,i)
516 IF (is /=0)THEN
517 DO j=1,nfunct
518 IF(is == npc1(j)) THEN
519 ipm(10+k,i)=j
520 GOTO 378
521 ENDIF
522 ENDDO
523 CALL ancmsg(msgid=126,
524 . msgtype=msgerror,
525 . anmode=aninfo_blind_1,
526 . i1=id,
527 . c1=titr,
528 . i2=is)
529 ENDIF
530 378 CONTINUE
531 IF (nf > 0) THEN
532 ife=ipm(10+nf,i)
533 ie =npc(ife)
534 ie2=npc(ife+1)
535 DO ii = ie+1,ie2-3,2
536 IF(pld(ii) < pld(ii+2))THEN
537 CALL ancmsg(msgid=975,
538 . msgtype=msgerror,
539 . anmode=aninfo,
540 . i1=id,
541 . c1=titr)
542 EXIT
543 ENDIF
544 ENDDO
545 ENDIF
546C law 88 - tabulated ogden law removed to updmat.F
547 ELSEIF (ilaw < 29) THEN
548C
549 nf = ipm(10,i)
550 IF (nf > 0) THEN
551 DO k=1,nf
552 is = ipm(10+k,i)
553 ok = 0
554 IF (is > 0) THEN
555 DO j=1,nfunct
556 IF(is == npc1(j)) THEN
557 ipm(10+k,i)=j
558 ok = 1
559 EXIT
560 ENDIF
561 ENDDO
562 IF (ok == 0) THEN
563 CALL ancmsg(msgid=126,
564 . msgtype=msgerror,
565 . anmode=aninfo_blind_1,
566 . i1=id,
567 . c1=titr,
568 . i2=is)
569 ENDIF
570 ENDIF
571 ENDDO
572 ENDIF
573 ENDIF
574C------------
575183 CONTINUE
576C------------
577C END OF LOOP ON MATS:
578 300 CONTINUE
579
580
581 !---EOS INPUT BASED ON FUNCTION (TABULATED EoS : IEOS=17 ---!
582 DO imat=1,nummat
583 ieos = ipm(4,imat)
584
585 IF(ieos == 17)THEN
586
587 id=ipm(1,imat)
588 CALL fretitl2(titr,ipm(npropmi-ltitr+1,imat),ltitr)
589 ilaw=ipm(2,i)
590
591 a_func = pm(35,imat)
592 IF(a_func /= 0)THEN
593 is_found = .false.
594 DO j=1,nfunct
595 IF(a_func == npc1(j)) THEN
596 pm(35,imat)=j
597 is_found = .true.
598 EXIT
599 ENDIF
600 ENDDO
601 IF(.NOT.is_found)CALL ancmsg(msgid=125,msgtype=msgerror,anmode=aninfo_blind_1, i1=id, c1=titr, i2=a_func)
602 ENDIF
603
604 b_func = pm(36,imat)
605 IF(b_func /= 0)THEN
606 is_found = .false.
607 DO j=1,nfunct
608 IF(b_func == npc1(j)) THEN
609 pm(36,imat)=j
610 is_found = .true.
611 EXIT
612 ENDIF
613 ENDDO
614 IF(.NOT.is_found)CALL ancmsg(msgid=125,msgtype=msgerror,anmode=aninfo_blind_1, i1=id, c1=titr, i2=b_func)
615 ENDIF
616
617 ENDIF
618
619 ENDDO
620
621
622C
623C 3) PID SPRING/AIRBAG/GENERAL SPRING
624C
625 DO 420 i=1,numgeo
626C
627 igtyp=igeo(11,i)
628C
629 id=igeo(1,i)
630 CALL fretitl2(titr,igeo(npropgi-ltitr+1,i),ltitr)
631C
632 IF (igtyp == 4) THEN
633C
634 iserv(1)=igeo(101,i)
635 iserv(2)=igeo(102,i)
636 iserv(3)=igeo(103,i)
637 load0 =igeo(101,i)
638 unload0=igeo(103,i)
639 iserv(4)=4
640 iserv(5)=14
641 iserv(6)=18
642 h = geo(7,i)
643 DO 330 k=1,3
644 IF(iserv(k)/=0) THEN
645 DO 320 j=1,nfunct
646 IF(iserv(k) == npc1(j)) THEN
647 geo(iserv(k+3),i)=j+pun
648 igeo(100+k,i)=j
649 GO TO 330
650 ENDIF
651 320 CONTINUE
652 CALL ancmsg(msgid=127,
653 . msgtype=msgerror,
654 . anmode=aninfo_blind_1,
655 . i1=id,
656 . c1=titr,
657 . i2=iserv(k))
658 ENDIF
659 330 CONTINUE
660 IF (igeo(119,i) /=0)THEN
661 errf = 1
662 DO j=1,nfunct
663 IF(igeo(119,i) == npc1(j)) THEN
664 igeo(119,i)=j
665 errf = 0
666 EXIT
667 ENDIF
668 ENDDO
669 IF (errf == 1) THEN
670 CALL ancmsg(msgid=127,
671 . msgtype=msgerror,
672 . anmode=aninfo_blind_1,
673 . i1=id,
674 . c1=titr,
675 . i2=igeo(119,i))
676 ENDIF
677 ENDIF
678 !compute max slope for ifunc3
679 yfac = geo(132,i) !GF3 in lecgeo4
680 ifunc = igeo(119,i) !IFUNC3 in lecgeo4
681 x_scale = geo(18,i)
682 IF (ifunc /= 0)THEN
683 ic1 = npc(ifunc)
684 ic2 = npc(ifunc+1)
685 x0 = pld(ic1)
686 emax = zero
687 DO ii = ic1,ic2-4,2
688 jj = ii+2
689 dx = pld(jj) - x0
690 dy = pld(jj+1) - pld(ii+1)
691 y0 = pld(ii+1)
692 y1 = pld(jj+1)
693 deri = yfac * x_scale * dy / dx
694 x1 = pld(jj)
695 emax = max(emax, deri)
696 x0 = pld(jj)
697 ENDDO
698 geo(141,i) = emax
699 ENDIF
700
701 IF (h == 7)THEN
702 xscale=geo(39,i)
703 load=igeo(101,i)
704 unload=igeo(103,i)
705 np1 = (npc(load+1)-npc(load)) / 2
706 np2 = (npc(unload+1)-npc(unload)) / 2
707 alpha1=zero
708 alpha2=zero
709c IF(NPC(2*NFUNCT+LOAD+1) <0 .OR. NPC(2*NFUNCT+UNLOAD+1) <0)THEN
710 IF(.false.) THEN
711 ! at least one python function
712 ELSE
713 DO 777 j=2,np1
714 j1=2*(j-2)
715 s1=pld(npc(load)+j1)*xscale
716 s2=pld(npc(load)+j1+2)*xscale
717 t1=pld(npc(load)+j1+1)
718 t2=pld(npc(load)+j1+3)
719 ty=zero
720 sx=zero
721 IF ( s1<=zero .AND.s2> zero)alpha1=(t2-t1)/(s2-s1)
722 DO k=2,np2
723 k1=2*(k-2)
724 xx1=pld(npc(unload)+k1)*xscale
725 x2 =pld(npc(unload)+k1+2)*xscale
726 yy1=pld(npc(unload)+k1+1)
727 y2 =pld(npc(unload)+k1+3)
728 IF ( xx1<=zero .AND.x2> zero)alpha2=(y2-yy1)/(x2-xx1)! CROSSING THROUGH ZERO
729 IF (y2>=t1 .AND.yy1<=t2.AND.x2>=s1.AND.xx1<=s2)THEN
730 dydx = (y2-yy1) / (x2-xx1)
731 dtds = (t2-t1) / (s2-s1)
732 IF (dydx > dtds) THEN ! INTERSECTION OF CURVES
733 sx = (t1-yy1-dtds*s1+dydx*xx1) / (dydx-dtds)
734 ty = t1 + dtds*(sx - s1)
735 ENDIF
736 IF (ty/=zero .AND. sx/=zero )THEN
737 IF (ty>=yy1.AND.ty<=y2.AND.sx>=xx1.AND.sx<=x2
738 . .AND.sx>=s2.AND.ty<=t2)THEN
739
740 CALL ancmsg(msgid=982,
741 . msgtype=msgerror,
742 . anmode=aninfo_blind_1,
743 . c1=titr,
744 . i1=unload0,
745 . i2=load0)
746 GOTO 777
747 ENDIF
748 ENDIF
749 ENDIF
750 ENDDO
751 777 CONTINUE
752 IF(alpha2>=alpha1)THEN
753 CALL ancmsg(msgid=982,
754 . msgtype=msgerror,
755 . anmode=aninfo_blind_1,
756 . c1=titr,
757 . i1=unload,
758 . i2=load)
759 ENDIF
760 ENDIF
761 ENDIF
762c-------
763 ELSEIF(igtyp == 12) THEN
764C
765 iserv(1)=igeo(101,i)
766 iserv(2)=igeo(102,i)
767 iserv(3)=igeo(103,i)
768 h = geo(7,i)
769 DO 331 k=1,3
770 IF(iserv(k)/=0) THEN
771 DO j=1,nfunct
772 IF(iserv(k) == npc1(j)) THEN
773 igeo(100+k,i)=j
774 GO TO 331
775 ENDIF
776 ENDDO
777 CALL ancmsg(msgid=127,
778 . msgtype=msgerror,
779 . anmode=aninfo_blind_1,
780 . i1=id,
781 . c1=titr,
782 . i2=iserv(k))
783 ENDIF
784 331 CONTINUE
785 IF (igeo(201,i) > 0) THEN
786 DO j=1,ntable
787 IF (igeo(201,i) == table(j)%NOTABLE) THEN
788 igeo(201,i) = j
789 GOTO 332
790 ENDIF
791 END DO
792 CALL ancmsg(msgid=779,
793 . msgtype=msgerror,
794 . anmode=aninfo,
795 . i1=id,
796 . c1=titr,
797 . i2=itable)
798 ENDIF
799 332 CONTINUE
800c
801 IF (igeo(119,i) /=0)THEN
802 errf = 1
803 DO j=1,nfunct
804 IF(igeo(119,i) == npc1(j)) THEN
805 igeo(119,i)=j
806 errf = 0
807 EXIT
808 ENDIF
809 ENDDO
810 IF (errf == 1) THEN
811 CALL ancmsg(msgid=127,
812 . msgtype=msgerror,
813 . anmode=aninfo_blind_1,
814 . i1=id,
815 . c1=titr,
816 . i2=igeo(119,i))
817 ENDIF
818 ENDIF
819
820 yfac = geo(132,i) !GF3 in lecgeo12
821 ifunc = igeo(119,i) !IFUNC3 in lecgeo12
822 x_scale = geo(18,i)
823 IF (ifunc /= 0)THEN
824 ic1 = npc(ifunc)
825 ic2 = npc(ifunc+1)
826 x0 = pld(ic1)
827 emax = zero
828 DO ii = ic1,ic2-4,2
829 jj = ii+2
830 dx = pld(jj) - x0
831 dy = pld(jj+1) - pld(ii+1)
832 y0 = pld(ii+1)
833 y1 = pld(jj+1)
834 deri = yfac * x_scale * dy / dx
835 x1 = pld(jj)
836 emax = max(emax, deri)
837 x0 = pld(jj)
838 ENDDO
839 geo(141,i) = emax ! slope max
840 ENDIF
841
842 IF (h == 7)THEN
843 xscale=geo(39,i)
844 load=igeo(101,i)
845 unload=igeo(103,i)
846 np1 = (npc(load+1)-npc(load)) / 2
847 np2 = (npc(unload+1)-npc(unload)) / 2
848 alpha1=zero
849 alpha2=zero
850c IF(NPC(2*NFUNCT+LOAD+1) <0 .OR. NPC(2*NFUNCT+UNLOAD+1) <0)THEN
851 IF(.false.) THEN
852 ! at least one python function
853 ELSE
854
855c---
856 DO 778 j=2,np1
857 j1=2*(j-2)
858 s1=pld(npc(load)+j1)*xscale
859 s2=pld(npc(load)+j1+2)*xscale
860 t1=pld(npc(load)+j1+1)
861 t2=pld(npc(load)+j1+3)
862 ty=zero
863 sx=zero
864 IF ( s1<=zero .AND.s2> zero)alpha1=(t2-t1)/(s2-s1)
865 DO k=2,np2
866 k1=2*(k-2)
867 xx1=pld(npc(unload)+k1)*xscale
868 x2=pld(npc(unload)+k1+2)*xscale
869 yy1=pld(npc(unload)+k1+1)
870 y2=pld(npc(unload)+k1+3)
871 IF ( xx1<=zero .AND.x2> zero)alpha2=(y2-yy1)/(x2-xx1)
872 IF (y2>=t1 .AND.yy1<=t2.AND.x2>=s1.AND.xx1<=s2)THEN
873 dydx = (y2-yy1) / (x2-xx1)
874 dtds = (t2-t1) / (s2-s1)
875 IF (dydx > dtds) THEN
876 sx = (t1-yy1-dtds*s1+dydx*xx1) / (dydx-dtds)
877 ty = t1 + dtds*(sx - s1)
878 ENDIF
879 IF (ty/=zero .AND. sx/=zero )THEN
880 IF (ty>=yy1.AND.ty<=y2.AND.sx>=xx1.AND.sx<=x2
881 . .AND.sx>=s2.AND.ty<=t2)THEN
882 CALL ancmsg(msgid=982,
883 . msgtype=msgerror,
884 . anmode=aninfo_blind_1,
885 . c1=titr,
886 . i1=unload,
887 . i2=load)
888 GOTO 778
889 ENDIF
890 ENDIF
891 ENDIF
892 ENDDO
893 778 CONTINUE
894 IF(alpha2>=alpha1)THEN
895 CALL ancmsg(msgid=982,
896 . msgtype=msgerror,
897 . anmode=aninfo_blind_1,
898 . c1=titr,
899 . i1=unload,
900 . i2=load)
901 ENDIF
902 ENDIF
903 ENDIF
904C
905 ELSE IF(igtyp == 7) THEN
906C
907 iserv(1)=nint(geo(19,i))
908 iserv(2)=nint(geo(44,i))
909 iserv(3)=19
910 iserv(4)=44
911 DO 360 k=1,2
912 DO 340 j=1,nfunct
913 IF(iserv(k) == npc1(j)) THEN
914 geo(iserv(k+2),i)=j+pun
915 GO TO 360
916 ENDIF
917 340 CONTINUE
918 CALL ancmsg(msgid=127,
919 . msgtype=msgerror,
920 . anmode=aninfo_blind_1,
921 . i1=id,
922 . c1=titr,
923 . i2=iserv(k))
924 360 CONTINUE
925c------------------------
926 ELSEIF(igtyp==8.OR.igtyp==13) THEN
927C
928 DO 400 j=1,6
929 iserv(1)=igeo(101+3*(j-1),i)
930 iserv(2)=igeo(102+3*(j-1),i)
931 iserv(3)=igeo(103+3*(j-1),i)
932 iflag1 = 0
933 iflag2 = 0
934 iflag3 = 0
935 IF(iserv(1) == 0)iflag1=1
936 IF(iserv(2) == 0)iflag2=1
937 IF(iserv(3) == 0)iflag3=1
938 IF(iflag1+iflag2+iflag3 == 3)GOTO 400
939 DO 380 k=1,nfunct
940 IF(iserv(1) == npc1(k)) THEN
941 igeo(101+3*(j-1),i) = k
942 iflag1=1
943 ENDIF
944 IF(iserv(2) == npc1(k)) THEN
945 igeo(102+3*(j-1),i) = k
946 iflag2=1
947 ENDIF
948 IF(iserv(3) == npc1(k)) THEN
949 igeo(103+3*(j-1),i) = k
950 iflag3=1
951 ENDIF
952 IF(iflag1+iflag2+iflag3 == 3)GOTO 400
953 380 CONTINUE
954
955 IF(iflag1 == 0) id1=iserv(1)
956 IF(iflag2 == 0) id1=iserv(2)
957 IF(iflag3 == 0) id1=iserv(3)
958 CALL ancmsg(msgid=127,
959 . msgtype=msgerror,
960 . anmode=aninfo_blind_1,
961 . i1=id,
962 . c1=titr,
963 . i2=id1)
964 400 CONTINUE
965c --------
966 DO j=1, 6
967 errf = 1
968 IF (igeo(119+j-1,i) /=0)THEN
969 DO k=1,nfunct
970 IF(igeo(119+j-1,i) == npc1(k)) THEN !ifunc3
971 igeo(119+j-1,i) = k
972 errf = 0
973 EXIT
974 ENDIF
975 ENDDO
976 IF (errf == 1)THEN
977 IF (igtyp == 8)THEN
978 ELSE
979 ENDIF
980 CALL ancmsg(msgid=127,
981 . msgtype=msgerror,
982 . anmode=aninfo_blind_1,
983 . i1=id,
984 . c1=titr,
985 . i2=igeo(119+j-1,i))
986 ENDIF
987 ENDIF
988 ENDDO
989!compute max slope for ifunc3
990 DO j=1, 6
991 yfac = geo(131+j,i) !GF3 in lecgeo13 -8
992 ifunc = igeo(118+j,i) !IFUNC3 in lecgeo13 -8
993 x_scale=geo(44+4*(j-1),i)
994 IF (ifunc /= 0)THEN
995 ic1 = npc(ifunc)
996 ic2 = npc(ifunc+1)
997 x0 = pld(ic1)
998 emax = zero
999 DO ii = ic1,ic2-4,2
1000 jj = ii+2
1001 dx = pld(jj) - x0
1002 dy = pld(jj+1) - pld(ii+1)
1003 y0 = pld(ii+1)
1004 y1 = pld(jj+1)
1005 deri = yfac * x_scale * dy / dx
1006 x1 = pld(jj)
1007 emax = max(emax, deri)
1008 x0 = pld(jj)
1009 ENDDO
1010 geo(140+j,i) = emax ! max slope for ifunc3
1011 ENDIF
1012 ENDDO
1013C
1014 DO 877 j=1, 6
1015 IF(j<= 2)THEN
1016 h=geo(7*j,i)
1017 ELSE
1018 h=geo(14+(j-2)*4,i)
1019 ENDIF
1020 IF (h == 7)THEN
1021 IF (j==1)THEN
1022 xscale=geo(39,i)
1023 ELSE
1024 xscale=geo(172+j,i)
1025 ENDIF
1026 load=igeo(101+3*(j-1),i)
1027 unload=igeo(103+3*(j-1),i)
1028 np1 = (npc(load+1)-npc(load))*half
1029 np2 = (npc(unload+1)-npc(unload))*half
1030 alpha1=zero
1031 alpha2=zero
1032c IF(NPC(2*NFUNCT+LOAD+1) <0 .OR. NPC(2*NFUNCT+UNLOAD+1) <0)THEN
1033 IF(.false.) THEN
1034 ! at least one python function
1035 ELSE
1036
1037c---
1038 DO jj=2,np1
1039 j1=2*(jj-2)
1040 s1=pld(npc(load)+j1)*xscale
1041 s2=pld(npc(load)+j1+2)*xscale
1042 t1=pld(npc(load)+j1+1)
1043 t2=pld(npc(load)+j1+3)
1044 ty=zero
1045 sx=zero
1046 IF ( s1<=zero .AND.s2> zero)alpha1=(t2-t1)/(s2-s1)
1047 DO k=2,np2
1048 k1=2*(k-2)
1049 xx1=pld(npc(unload)+k1)*xscale
1050 x2=pld(npc(unload)+k1+2)*xscale
1051 yy1=pld(npc(unload)+k1+1)
1052 y2=pld(npc(unload)+k1+3)
1053 IF ( xx1<=zero .AND.x2> zero)alpha2=(y2-yy1)/(x2-xx1)
1054 IF (y2>=t1 .AND.yy1<=t2.AND.x2>=s1.AND.xx1<=s2)THEN
1055 dydx = (y2-yy1) / (x2-xx1)
1056 dtds = (t2-t1) / (s2-s1)
1057 IF (dydx > dtds) THEN
1058 sx = (t1-yy1-dtds*s1+dydx*xx1) / (dydx-dtds)
1059 ty = t1 + dtds*(sx - s1)
1060 ENDIF
1061 IF (ty/=zero .AND. sx/=zero )THEN
1062 IF (ty>=yy1.AND.ty<=y2.AND.sx>=xx1.AND.sx<=x2
1063 . .AND.sx>=s2.AND.ty<=t2)THEN
1064 IF (igtyp == 8)THEN
1065 ELSE
1066 ENDIF
1067 CALL ancmsg(msgid=982,
1068 . msgtype=msgerror,
1069 . anmode=aninfo_blind_1,
1070 . c1=titr,
1071 . i1=unload,
1072 . i2=load)
1073 GOTO 877
1074 ENDIF
1075 ENDIF
1076 ENDIF
1077 ENDDO
1078 ENDDO
1079 IF(alpha2>=alpha1)THEN
1080 IF (igtyp == 8)THEN
1081 ELSE
1082 ENDIF
1083 CALL ancmsg(msgid=982,
1084 . msgtype=msgerror,
1085 . anmode=aninfo_blind_1,
1086 . c1=titr,
1087 . i1=unload,
1088 . i2=load)
1089 ENDIF
1090 ENDIF
1091 ENDIF
1092 877 CONTINUE
1093
1094C ENDDO
1095c --------
1096C
1097 ELSEIF (igtyp==25) THEN
1098C
1099 DO 401 j=1,4 ! instead of 6 pmo
1100 iserv(1)=igeo(102+4*(j-1),i)
1101 iserv(2)=igeo(103+4*(j-1),i)
1102 iserv(3)=igeo(104+4*(j-1),i)
1103 iflag1 = 0
1104 iflag2 = 0
1105 iflag3 = 0
1106 IF(iserv(1) == 0)iflag1=1
1107 IF(iserv(2) == 0)iflag2=1
1108 IF(iserv(3) == 0)iflag3=1
1109 IF(iflag1+iflag2+iflag3 == 3)GOTO 401
1110 DO 381 k=1,nfunct
1111 IF(iserv(1) == npc1(k)) THEN
1112 igeo(102+4*(j-1),i) = k
1113 iflag1=1
1114 ENDIF
1115 IF(iserv(2) == npc1(k)) THEN
1116 igeo(103+4*(j-1),i) = k
1117 iflag2=1
1118 ENDIF
1119 IF(iserv(3) == npc1(k)) THEN
1120 igeo(104+4*(j-1),i) = k
1121 iflag3=1
1122 ENDIF
1123 IF(iflag1+iflag2+iflag3 == 3)GOTO 401
1124 381 CONTINUE
1125 IF(iflag1 == 0) id1=iserv(1)
1126 IF(iflag2 == 0) id1=iserv(2)
1127 IF(iflag3 == 0) id1=iserv(3)
1128 CALL ancmsg(msgid=127,
1129 . msgtype=msgerror,
1130 . anmode=aninfo_blind_1,
1131 . i1=id,
1132 . c1=titr,
1133 . i2=id1)
1134 401 CONTINUE
1135C
1136c --------
1137 DO j=1,4
1138 errf = 1
1139 IF (igeo(119+j-1,i) /=0)THEN
1140 DO k=1,nfunct
1141 IF(igeo(119+j-1,i) == npc1(k)) THEN
1142 igeo(119+j-1,i) = k
1143 errf = 0
1144 EXIT
1145 ENDIF
1146 ENDDO
1147 IF (errf == 1)THEN
1148 CALL ancmsg(msgid=127,
1149 . msgtype=msgerror,
1150 . anmode=aninfo_blind_1,
1151 . i1=id,
1152 . c1=titr,
1153 . i2=igeo(119+j-1,i))
1154 ENDIF
1155 ENDIF
1156 ENDDO
1157!compute max slope for ifunc3
1158 DO j=1, 4
1159 yfac = geo(131+j,i) !GF3 in lecgeo25
1160 ifunc = igeo(118+j,i) !IFUNC3 in lecgeo25
1161 IF (j==1) x_scale = geo(44,i)
1162 IF (j==2) x_scale = geo(48,i)
1163 IF (j==3) x_scale = geo(56,i)
1164 IF (j==4) x_scale = geo(60,i)
1165 IF (ifunc /= 0)THEN
1166 ic1 = npc(ifunc)
1167 ic2 = npc(ifunc+1)
1168 x0 = pld(ic1)
1169 emax = zero
1170 DO ii = ic1,ic2-4,2
1171 jj = ii+2
1172 dx = pld(jj) - x0
1173 dy = pld(jj+1) - pld(ii+1)
1174 y0 = pld(ii+1)
1175 y1 = pld(jj+1)
1176 deri = yfac * x_scale * dy / dx
1177 x1 = pld(jj)
1178 emax = max(emax, deri)
1179 x0 = pld(jj)
1180 ENDDO
1181 geo(140+j,i) = emax
1182 ENDIF
1183 ENDDO
1184
1185 DO 888 j=1,4
1186 h=igeo(101+(j-1)*4,i)
1187 IF (h == 7)THEN
1188 IF (j==1)THEN
1189 xscale=geo(39,i)
1190 ELSEIF (j==2)THEN
1191 xscale=geo(174,i)
1192 ELSEIF (j==3)THEN
1193 xscale=geo(176,i)
1194 ELSEIF (j==4)THEN
1195 xscale=geo(177,i)
1196 ENDIF
1197 load=igeo(102+4*(j-1),i)
1198 unload=igeo(103+4*(j-1),i)
1199 np1 = (npc(load+1)-npc(load))*half
1200 np2 = (npc(unload+1)-npc(unload))*half
1201 alpha1=zero
1202 alpha2=zero
1203C IF(NPC(2*NFUNCT+LOAD+1) <0 .OR. NPC(2*NFUNCT+UNLOAD+1) <0)THEN
1204 IF(.false.) THEN
1205 ! at least one python function
1206 ELSE
1207c---
1208 DO jj=2,np1
1209 j1=2*(jj-2)
1210 s1=pld(npc(load)+j1)*xscale
1211 s2=pld(npc(load)+j1+2)*xscale
1212 t1=pld(npc(load)+j1+1)
1213 t2=pld(npc(load)+j1+3)
1214 ty=zero
1215 sx=zero
1216 IF ( s1<=zero .AND.s2> zero)alpha1=(t2-t1)/(s2-s1)
1217 DO k=2,np2
1218 k1=2*(k-2)
1219 xx1=pld(npc(unload)+k1)*xscale
1220 x2=pld(npc(unload)+k1+2)*xscale
1221 yy1=pld(npc(unload)+k1+1)
1222 y2=pld(npc(unload)+k1+3)
1223 IF ( xx1<=zero .AND.x2> zero)alpha2=(y2-yy1)/(x2-xx1)
1224 IF (y2>=t1 .AND.yy1<=t2.AND.x2>=s1.AND.xx1<=s2)THEN
1225 dydx = (y2-yy1) / (x2-xx1)
1226 dtds = (t2-t1) / (s2-s1)
1227 IF (dydx > dtds) THEN
1228 sx = (t1-yy1-dtds*s1+dydx*xx1) / (dydx-dtds)
1229 ty = t1 + dtds*(sx - s1)
1230 ENDIF
1231 IF (ty/=zero .AND. sx/=zero )THEN
1232 IF (ty>=yy1.AND.ty<=y2.AND.sx>=xx1.AND.sx<=x2
1233 . .AND.sx>=s2.AND.ty<=t2)THEN
1234 CALL ancmsg(msgid=982,
1235 . msgtype=msgerror,
1236 . anmode=aninfo_blind_1,
1237 . c1=titr,
1238 . i1=unload,
1239 . i2=load)
1240 GOTO 888
1241 ENDIF
1242 ENDIF
1243 ENDIF
1244 ENDDO
1245 ENDDO
1246 IF(alpha2>=alpha1)THEN
1247 CALL ancmsg(msgid=982,
1248 . msgtype=msgerror,
1249 . anmode=aninfo_blind_1,
1250 . c1=titr,
1251 . i1=unload,
1252 . i2=load)
1253 ENDIF
1254 ENDIF
1255 ENDIF ! H == 7
1256 888 CONTINUE
1257c --------
1258 ELSEIF (igtyp == 26) THEN
1259 nfunc = igeo(20,i)
1260 nfund = igeo(21,i)
1261 iadd = 100
1262 DO k=1,nfunc
1263 iflag1 = 0
1264 DO j=1,nfunct
1265 IF (igeo(iadd+k,i) == npc1(j)) THEN
1266 igeo(iadd+k,i) = j
1267 iflag1 = 1
1268 EXIT
1269 ENDIF
1270 ENDDO
1271 IF (iflag1 == 0) THEN
1272 ENDIF
1273 ENDDO
1274 iadd = nfunc+100
1275 DO k=1,nfund
1276 iflag1 = 0
1277 DO j=1,nfunct
1278 IF (igeo(iadd+k,i) == npc1(j)) THEN
1279 igeo(iadd+k,i) = j
1280 iflag1 = 1
1281 EXIT
1282 ENDIF
1283 ENDDO
1284 IF (iflag1 == 0) THEN
1285 ENDIF
1286 ENDDO
1287
1288 ELSEIF (igtyp == 27) THEN
1289C
1290 ! Convert User ID function in internal ID
1291 iserv(1) = igeo(101,i)
1292 iserv(2) = igeo(102,i)
1293 iserv(3) = 4
1294 iserv(4) = 14
1295 DO k=1,2
1296 iflag1 = 0
1297 IF (iserv(k) /= 0) THEN
1298 DO j=1,nfunct
1299 IF (iserv(k) == npc1(j)) THEN
1300 geo(iserv(k+2),i) = j+pun
1301 igeo(100+k,i) = j
1302 iflag1 = 1
1303 EXIT
1304 ENDIF
1305 ENDDO
1306 IF (iflag1 == 0) THEN
1307 CALL ancmsg(msgid=127,
1308 . msgtype=msgerror,
1309 . anmode=aninfo_blind_1,
1310 . i1=id,
1311 . c1=titr,
1312 . i2=iserv(k+2))
1313 ENDIF
1314 ENDIF
1315 ENDDO
1316 ! Compute max slop for damping
1317 ifunc = igeo(102,i)
1318 IF (ifunc /= 0)THEN
1319 yfac = geo(132,i)
1320 x_scale = geo(18,i)
1321 ic1 = npc(ifunc)
1322 ic2 = npc(ifunc+1)
1323 x0 = pld(ic1)
1324 emax = zero
1325 DO ii = ic1,ic2-4,2
1326 jj = ii+2
1327 dx = pld(jj) - x0
1328 dy = pld(jj+1) - pld(ii+1)
1329 y0 = pld(ii+1)
1330 y1 = pld(jj+1)
1331 deri = yfac * x_scale * dy / dx
1332 x1 = pld(jj)
1333 emax = max(emax,deri)
1334 x0 = pld(jj)
1335 ENDDO
1336 geo(141,i) = emax
1337 ENDIF
1338 ENDIF
1339C
1340 420 CONTINUE
1341
1342C
1343C
1344C 4) CONCENTRATED LOADS
1345C
1346 DO 460 i=1,nconld-npreld
1347 DO 440 j=1,nfunct
1348 IF(ibcl(3,i) == npc1(j)) THEN
1349 ibcl(3,i)=j
1350 GOTO 460
1351 ENDIF
1352 440 CONTINUE
1353 CALL ancmsg(msgid=120,
1354 . msgtype=msgerror,
1355 . anmode=aninfo_blind_1,
1356 . c1='CONCENTRED LOADS',
1357 . i1=ibcl(3,i))
1358 460 CONTINUE
1359C
1360C 5) PRESSURE LOADS
1361C
1362 DO 500 i=1,npreld
1363 DO 480 j=1,nfunct
1364 IF(ipres(5,i) == npc1(j)) THEN
1365 ipres(5,i)=j
1366 GO TO 500
1367 ENDIF
1368 480 CONTINUE
1369 CALL ancmsg(msgid=120,
1370 . msgtype=msgerror,
1371 . anmode=aninfo_blind_1,
1372 . c1='PRESSURE LOADS',
1373 . i1=ipres(5,i))
1374 500 CONTINUE
1375C
1376C 6) FIXED DISPLACEMENTS
1377C
1378
1379 DO i=1,nimpdisp
1380 ok = 0
1381 DO j=1,nfunct
1382 IF(ibfv(3,i) == npc1(j)) THEN
1383 ibfv(3,i)=j
1384 ok = 1
1385 EXIT
1386 END IF
1387 END DO
1388
1389 IF (ok == 0) THEN
1390 CALL ancmsg(msgid=120,
1391 . msgtype=msgerror,
1392 . anmode=aninfo_blind_1,
1393 . c1='IMPOSED DISPLACEMENTS',
1394 . i1=ibfv(3,i))
1395 END IF
1396 END DO
1397c
1398 DO i=1,nimpdisp
1399 ok = 0
1400 DO j=1,nfunct
1401 IF (ibfv(15,i)== 0) THEN
1402 ok = 1
1403 EXIT
1404 ELSE
1405 IF(ibfv(15,i) == npc1(j)) THEN
1406 ibfv(15,i)=j
1407 ok = 1
1408 EXIT
1409 ENDIF
1410 ENDIF
1411 END DO
1412 IF (ok == 0) THEN
1413 CALL ancmsg(msgid=120,
1414 . msgtype=msgerror,
1415 . anmode=aninfo_blind_1,
1416 . c1='IMPOSED DISPLACEMENTS',
1417 . i1=ibfv(3,i))
1418 END IF
1419 END DO
1420C
1421C 7) FIXED VELOCITIES
1422C
1423 DO i=1+nimpdisp,nimpvel+nimpdisp
1424 ok = 0
1425 DO j=1,nfunct
1426 IF(ibfv(3,i) == npc1(j)) THEN
1427 ibfv(3,i)=j
1428 ok = 1
1429 EXIT
1430 END IF
1431 END DO
1432 IF (ok == 0) THEN
1433 CALL ancmsg(msgid=120,
1434 . msgtype=msgerror,
1435 . anmode=aninfo_blind_1,
1436 . c1='IMPOSED VELOCITIES',
1437 . i1=ibfv(3,i))
1438 END IF
1439 END DO
1440c
1441 DO i=1+nimpdisp,nimpvel+nimpdisp
1442 ok = 0
1443 DO j=1,nfunct
1444 IF (ibfv(15,i)== 0) THEN
1445 ok = 1
1446 EXIT
1447 ELSE
1448 IF(ibfv(15,i) == npc1(j)) THEN
1449 ibfv(15,i)=j
1450 ok = 1
1451 EXIT
1452 END IF
1453 END IF
1454 END DO
1455 IF(ok == 0) THEN
1456 CALL ancmsg(msgid=120,
1457 . msgtype=msgerror,
1458 . anmode=aninfo_blind_1,
1459 . c1='IMPOSED VELOCITIES',
1460 . i1=ibfv(3,i))
1461 END IF
1462 END DO
1463C
1464C 8) FIXED ACCELERATIONS
1465C
1466 DO i=1+nimpvel+nimpdisp,nimpacc+nimpvel+nimpdisp
1467 ok = 0
1468 DO j=1,nfunct
1469 IF(ibfv(3,i) == npc1(j)) THEN
1470 ibfv(3,i)=j
1471 ok = 1
1472 EXIT
1473 END IF
1474 END DO
1475
1476 IF (ok == 0) THEN
1477 CALL ancmsg(msgid=120,
1478 . msgtype=msgerror,
1479 . anmode=aninfo_blind_1,
1480 . c1='IMPOSED ACCELERATIONS',
1481 . i1=ibfv(3,i))
1482 END IF
1483 END DO
1484c
1485 DO i=1+nimpvel+nimpdisp,nimpacc+nimpvel+nimpdisp
1486 ok = 0
1487 DO j=1,nfunct
1488 IF (ibfv(15,i)== 0) THEN
1489 ok = 1
1490 EXIT
1491 ELSE
1492 IF(ibfv(15,i) == npc1(j)) THEN
1493 ibfv(15,i)=j
1494 ok = 1
1495 EXIT
1496 ENDIF
1497 ENDIF
1498 END DO
1499 IF (ok == 0) THEN
1500 CALL ancmsg(msgid=120,
1501 . msgtype=msgerror,
1502 . anmode=aninfo_blind_1,
1503 . c1='IMPOSED ACCELERATIONS',
1504 . i1=ibfv(3,i))
1505 END IF
1506 END DO
1507C=======================================================================
1508C
1509C (II) SKEW
1510C
1511C=======================================================================
1512C
1513C 1) BOUNDARY CONDITIONS
1514C
1515c DO 660 I=1,NUMNOD
1516c DO 640 J=0,NUMSKW
1517c IF(ISKEW(I) == ISKN(4,J+1)) THEN
1518c ISKEW(I)=J+1
1519c GO TO 660
1520c ENDIF
1521c 640 CONTINUE
1522c CALL ANSTCKC(19,'BOUNDARY CONDITIONS')
1523c CALL ANSTCKI(ISKEW(I))
1524c CALL ANCERR(137,ANINFO_BLIND_1)
1525c 660 CONTINUE
1526C
1527C 2) CONCENTRATED LOADS
1528C
1529c DO 700 I=1,NCONLD-NPRELD
1530c IS=IBCL(2,I)/10
1531c DO 680 J=0,NUMSKW
1532c IF(IS == ISKN(4,J+1)) THEN
1533c IBCL(2,I)=(J+1)*10+MOD(IBCL(2,I),10)
1534c GO TO 700
1535c ENDIF
1536c 680 CONTINUE
1537c CALL ANSTCKC(18,'CONCENTRATED LOADS')
1538c CALL ANSTCKI(IS)
1539c CALL ANCERR(137,ANINFO_BLIND_1)
1540c 700 CONTINUE
1541
1542
1543C
1544C 3) FIXED VELOCITIES
1545C
1546c DO 745 I=1,NFXVEL
1547c IF (IBFV(9,I)>0) THEN
1548c IS=IBFV(9,I)
1549c JJ=(NUMSKW+1)+MIN(IUN,NSPCOND)*NUMSPH+1
1550c DO J=1,NUMFRAM
1551c JJ = JJ+1
1552c IF(IS == ISKN(4,JJ)) THEN
1553c IBFV(9,I)=J+1
1554c GO TO 745
1555c ENDIF
1556c ENDDO
1557c ELSE
1558c IS=IBFV(2,I)/10
1559c DO J=0,NUMSKW
1560c IF(IS == ISKN(4,J+1)) THEN
1561c IBFV(2,I)=(J+1)*10+MOD(IBFV(2,I),10)
1562c GO TO 745
1563c ENDIF
1564c ENDDO
1565c ENDIF
1566c CALL ANSTCKC(18,'IMPOSED VELOCITIES')
1567c CALL ANSTCKI(IS)
1568c CALL ANCERR(137,ANINFO_BLIND_1)
1569c 745 CONTINUE
1570
1571
1572C---------------------------
1573C 9) FIXED temperatures
1574C---------------------------
1575 DO 751 i=1,glob_therm%NFXTEMP
1576 DO 750 j=1,nfunct
1577 IF(ibft(2,i) == npc1(j)) THEN
1578 ibft(2,i)=j
1579 GOTO 751
1580 ENDIF
1581 750 CONTINUE
1582 CALL ancmsg(msgid=120,
1583 . msgtype=msgerror,
1584 . anmode=aninfo_blind_1,
1585 . c1='IMPOSED TEMPERATURE',
1586 . i1=ibft(2,i))
1587 751 CONTINUE
1588C------------------------------
1589C 10 Convective Flow
1590C------------------------------
1591 DO 753 i=1,glob_therm%NUMCONV
1592 DO 752 j=1,nfunct
1593 IF(ibcv(5,i) == npc1(j)) THEN
1594 ibcv(5,i)=j
1595 GOTO 753
1596 ENDIF
1597 752 CONTINUE
1598 CALL ancmsg(msgid=120,
1599 . msgtype=msgerror,
1600 . anmode=aninfo_blind_1,
1601 . c1='FIXED FLUX',
1602 . i1=ibcv(5,i))
1603 753 CONTINUE
1604C-----------------------------
1605C 11) FIXED radiative flux
1606C-----------------------------
1607 DO 755 i=1,glob_therm%NUMRADIA
1608 DO 754 j=1,nfunct
1609 IF(ibcr(5,i) == npc1(j)) THEN
1610 ibcr(5,i)=j
1611 GOTO 755
1612 ENDIF
1613 754 CONTINUE
1614 CALL ancmsg(msgid=120,
1615 . msgtype=msgerror,
1616 . anmode=aninfo_blind_1,
1617 . c1='FIXED RADIATIVE FLUX',
1618 . i1=ibcr(5,i))
1619 755 CONTINUE
1620C---------------------------
1621C 12) FIXED heat flux
1622C---------------------------
1623 DO 757 i=1,glob_therm%NFXFLUX
1624 DO 756 j=1,nfunct
1625 IF(ibfflux(5,i) == npc1(j)) THEN
1626 ibfflux(5,i)=j
1627 GOTO 757
1628 ENDIF
1629 756 CONTINUE
1630 CALL ancmsg(msgid=120,
1631 . msgtype=msgerror,
1632 . anmode=aninfo_blind_1,
1633 . c1='FIXED HEAT FLUX',
1634 . i1=ibfflux(5,i))
1635 757 CONTINUE
1636
1637
1638C
1639c 4) PID SOLID, GENERAL SPRING, POROUS MEDIUM
1640C
1641c DO 780 I=1,NUMGEO
1642c IGTYP=IGEO(11,I)
1643c IF (IGTYP == 6 .OR. IGTYP == 21 .OR. IGTYP == 22) THEN
1644c IS=-IGEO(2,I)
1645c IF(IS>=0) THEN
1646c DO K=0,NUMSKW
1647c IF(IS == ISKN(4,K+1)) THEN
1648c IGEO(2,I)=-(K+1)
1649c GO TO 780
1650c ENDIF
1651c ENDDO
1652c CALL ANSTCKC(17,'ORTHOTROPIC SOLID')
1653c CALL ANSTCKI(IS)
1654c CALL ANCERR(137,ANINFO_BLIND_1)
1655c ENDIF
1656c ELSEIF(IGTYP == 34)THEN
1657c IS=NINT(GEO(2,I))
1658c IF (IS/=0)THEN
1659c DO 758 K=0,NUMSKW
1660c IF(IS == ISKN(4,K+1)) THEN
1661c GEO(2,I)=(K+1)+PUN
1662c IGEO(2,I)=K+1
1663c GO TO 780
1664c ENDIF
1665c 758 CONTINUE
1666c
1667c CALL ANSTCKC(18,'GENERAL SPH PID')
1668c CALL ANSTCKI(IS)
1669c CALL ANCERR(137,ANINFO_BLIND_1)
1670c ENDIF
1671
1672c ELSEIF(IGTYP == 8.OR.IGTYP == 13.OR.IGTYP == 25.OR.
1673c . (IGTYP>=29.AND.IGTYP<50)) THEN
1674c IS=IGEO(2,I)
1675c DO 760 K=0,NUMSKW
1676c IF(IS == ISKN(4,K+1)) THEN
1677c GEO(2,I)=(K+1)+PUN
1678c IGEO(2,I)=K+1
1679c GO TO 780
1680c ENDIF
1681c 760 CONTINUE
1682c CALL ANSTCKC(18,'GENERAL SPRING PID')
1683c CALL ANSTCKI(IS)
1684c CALL ANCERR(137,ANINFO_BLIND_1)
1685c ELSEIF(IGTYP == 15)THEN
1686c IS=NINT(GEO(27,I))
1687c DO 765 K=0,NUMSKW
1688c IF(IS == ISKN(4,K+1)) THEN
1689c GEO(27,I)=(K+1)+PUN
1690c GO TO 780
1691c ENDIF
1692c 765 CONTINUE
1693c CALL ANSTCKC(17,'POROUS MEDIUM PID')
1694c CALL ANSTCKI(IS)
1695c CALL ANCERR(137,ANINFO_BLIND_1)
1696c ENDIF
1697c 780 CONTINUE
1698C
1699C 5) RIGID BODIES
1700C
1701c DO 810 I=1,NRBYKIN
1702c IS = NPBY(9,I)
1703c DO 800 J=0,NUMSKW
1704c IF(IS == ISKN(4,J+1)) THEN
1705c NPBY(9,I)=J+1
1706c GO TO 810
1707c ENDIF
1708c 800 CONTINUE
1709c CALL ANSTCKC(12,'RIGID BODIES')
1710c CALL ANSTCKI(IS)
1711c CALL ANCERR(137,ANINFO_BLIND_1)
1712c 810 CONTINUE
1713C
1714C 5) ACCELEROMETER
1715C
1716c DO 850 I=1,NACCELM
1717c IS=LACCELM(3,I)
1718c IF(LACCELM(1,I) > 0) THEN
1719c DO J=0,NUMSKW
1720c IF(IS == ISKN(4,J+1)) THEN
1721c LACCELM(3,I)=J+1
1722c GO TO 850
1723c ENDIF
1724c ENDDO
1725c CALL ANSTCKC(13,'ACCELEROMETER')
1726c CALL ANSTCKI(IS)
1727c CALL ANCERR(137,ANINFO_BLIND_1)
1728c ENDIF
1729c 850 CONTINUE
1730c DO 880 I=1,NBCSLAG
1731c IS=IBCSLAG(4,I)
1732c DO J=0,NUMSKW
1733c IF(IS == ISKN(4,J+1)) THEN
1734c IBCSLAG(4,I)=J+1
1735c GO TO 880
1736c ENDIF
1737c ENDDO
1738c CALL ANSTCKC(36,'BOUNDARY CONDITIONS WITH LAGR. MULT.')
1739c CALL ANSTCKI(IS)
1740c CALL ANCERR(137,ANINFO_BLIND_1)
1741c 880 CONTINUE
1742C
1743C GRAVITY
1744c DO 890 I=1,NGRAV
1745c NOSKEW=IGRV(2,I)/10
1746c ND =IGRV(2,I)-10*NOSKEW
1747c DO 895 J=0,NUMSKW
1748c IF(NOSKEW == ISKN(4,J+1)) THEN
1749c IGRV(2,I)=ND+10*(J+1)
1750c GO TO 890
1751c ENDIF
1752c 895 CONTINUE
1753c CALL ANSTCKC(7,'GRAVITY')
1754c CALL ANSTCKI(NOSKEW)
1755c CALL ANCERR(137,ANINFO_BLIND_1)
1756c 890 CONTINUE
1757C
1758C=======================================================================
1759C
1760C (III) SENSOR NUMBERING
1761C
1762C=======================================================================
1763C CONVECTIVE HEAT FLUX
1764C-------------------------
1765 DO i=1,glob_therm%NUMCONV
1766 isens = ibcv(6,i)
1767 IF(isens/=0) THEN
1768 DO j=1,sensors%NSENSOR
1769 IF(isens == sensors%SENSOR_TAB(j)%SENS_ID) THEN
1770 ibcv(6,i) = j
1771 GO TO 801
1772 ENDIF
1773 ENDDO
1774 CALL ancmsg(msgid=1605,msgtype=msgerror,anmode=aninfo_blind_1,
1775 . c1='CONVECTIVE HEAT FLUX',i1=isens)
1776 ENDIF
1777 801 CONTINUE
1778 ENDDO
1779C------------------------
1780C RADIATIVE HEAT FLUX
1781C------------------------
1782 DO i=1,glob_therm%NUMRADIA
1783 isens = ibcr(6,i)
1784 IF(isens/=0) THEN
1785 DO j=1,sensors%NSENSOR
1786 IF(isens == sensors%SENSOR_TAB(j)%SENS_ID) THEN
1787 ibcr(6,i) = j
1788 GO TO 802
1789 ENDIF
1790 ENDDO
1791 CALL ancmsg(msgid=1605,msgtype=msgerror,anmode=aninfo_blind_1,
1792 . c1='RADIATIVE HEAT FLUX',i1=isens)
1793 ENDIF
1794 802 CONTINUE
1795 ENDDO
1796C---------------------
1797C IMPOSED HEAT FLUX
1798C---------------------
1799 DO i=1,glob_therm%NFXFLUX
1800 isens = ibfflux(6,i)
1801 IF(isens/=0) THEN
1802 DO j=1,sensors%NSENSOR
1803 IF(isens == sensors%SENSOR_TAB(j)%SENS_ID) THEN
1804 ibfflux(6,i) = j
1805 GO TO 803
1806 ENDIF
1807 ENDDO
1808 CALL ancmsg(msgid=1605,msgtype=msgerror,anmode=aninfo_blind_1,
1809 . c1='IMPOSED HEAT FLUX',i1=isens)
1810 ENDIF
1811 803 CONTINUE
1812 ENDDO
1813
1814C---------------------
1815C IMPOSED TEMPERATURE
1816C---------------------
1817 DO i=1,glob_therm%NFXTEMP
1818 isens = ibft(3,i)
1819 IF (isens > 0) THEN
1820 DO j=1,sensors%NSENSOR
1821 IF (isens == sensors%SENSOR_TAB(j)%SENS_ID) THEN
1822 ibft(3,i) = j
1823 EXIT
1824 ENDIF
1825 ENDDO
1826 END IF
1827 ENDDO
1828
1829C---------------------
1830C IMPOSED DISPLACEMENTS/VELOCITIES/ACCELERATIONS
1831C---------------------
1832 DO i=1,nfxvel
1833 isens = ibfvel(4,i)
1834 IF (isens > 0) THEN
1835 DO j=1,sensors%NSENSOR
1836 IF (isens == sensors%SENSOR_TAB(j)%SENS_ID) THEN
1837 ibfvel(4,i) = j
1838 EXIT
1839 ENDIF
1840 ENDDO
1841 END IF
1842 ENDDO
1843c
1844C----------------------------
1845C (IV) PROCESSING OF TABLES
1846C----------------------------
1847C
1848C 1) LOIS 73
1849C
1850 DO i=1,nummat
1851C
1852 ilaw=ipm(2,i)
1853C
1854 id=ipm(1,i)
1855 CALL fretitl2(titr,ipm(npropmi-ltitr+1,i),ltitr)
1856 IF(ilaw == 73) THEN
1857 itable=ipm(227,i)
1858 IF(itable/=0)THEN
1859 DO j=1,ntable
1860 IF(itable == table(j)%NOTABLE) THEN
1861 ipm(227,i)=j
1862 GOTO 900
1863 ENDIF
1864 END DO
1865 CALL ancmsg(msgid=779,
1866 . msgtype=msgerror,
1867 . anmode=aninfo,
1868 . i1=id,
1869 . c1=titr,
1870 . i2=itable)
1871 ENDIF
1872 900 CONTINUE
1873 itable=ipm(227,i)
1874 IF(table(itable)%NDIM/=3)THEN
1875 CALL ancmsg(msgid=780,
1876 . msgtype=msgerror,
1877 . anmode=aninfo_blind_1,
1878 . i1=id,
1879 . c1=titr,
1880 . i2=itable)
1881 END IF
1882c -- young evolution
1883 IF (nf > 0) THEN
1884 ife=ipm(10+nf,i)
1885 IF (ife /= 0)THEN
1886 ie =npc(ife)
1887 ie2=npc(ife+1)
1888 DO ii = ie+1,ie2-3,2
1889 IF(pld(ii) < pld(ii+2))THEN
1890 CALL ancmsg(msgid=975,
1891 . msgtype=msgerror,
1892 . anmode=aninfo,
1893 . i1=id,
1894 . c1=titr)
1895 EXIT
1896 ENDIF
1897 ENDDO
1898 ENDIF
1899 ENDIF
1900
1901 ELSEIF(ilaw == 74)THEN
1902 itable=ipm(227,i)
1903 IF(itable/=0)THEN
1904 DO j=1,ntable
1905 IF(itable == table(j)%NOTABLE) THEN
1906 ipm(227,i)=j
1907 GOTO 901
1908 ENDIF
1909 END DO
1910 CALL ancmsg(msgid=779,
1911 . msgtype=msgerror,
1912 . anmode=aninfo,
1913 . i1=id,
1914 . c1=titr,
1915 . i2=itable)
1916 ENDIF
1917 901 CONTINUE
1918 itable=ipm(227,i)
1919 IF(table(itable)%NDIM/=2.AND.table(itable)%NDIM/=3)THEN
1920 CALL ancmsg(msgid=823,
1921 . msgtype=msgerror,
1922 . anmode=aninfo_blind_1,
1923 . i1=id,
1924 . c1=titr,
1925 . i2=itable)
1926 END IF
1927c -- young evolution
1928 IF (nf > 0) THEN
1929 ife=ipm(10+nf,i)
1930 IF(ife /= 0)THEN
1931 ie =npc(ife)
1932 ie2=npc(ife+1)
1933 DO ii = ie+1,ie2-3,2
1934 IF(pld(ii) < pld(ii+2))THEN
1935 CALL ancmsg(msgid=975,
1936 . msgtype=msgerror,
1937 . anmode=aninfo,
1938 . i1=id,
1939 . c1=titr)
1940 EXIT
1941 ENDIF
1942 ENDDO
1943 ENDIF
1944 ENDIF
1945
1946
1947 ELSEIF(ilaw == 80)THEN
1948 DO 980 k = 1,ipm(226,i)!NTABLE
1949 itable= ipm(226+k,i)
1950 iadd = ipm(7,i) - 1
1951 IF(itable/=0)THEN
1952 DO j=1,ntable
1953 IF(itable == table(j)%NOTABLE) THEN
1954 ipm(226+k,i)=j
1955 itable=ipm(226+k,i)
1956 IF(table(itable)%NDIM >= 2 )THEN
1957 bufmat(iadd+15) = zero
1958 ENDIF
1959 IF(table(itable)%NDIM > 3 )THEN
1960 CALL ancmsg(msgid=1030,
1961 . msgtype=msgerror,
1962 . anmode=aninfo_blind_1,
1963 . i1=id,
1964 . c1=titr,
1965 . i2=itable)
1966 EXIT
1967 END IF
1968 GOTO 980
1969 ENDIF
1970 END DO
1971 CALL ancmsg(msgid=779,
1972 . msgtype=msgerror,
1973 . anmode=aninfo,
1974 . i1=id,
1975 . c1=titr,
1976 . i2=itable)
1977 ENDIF
1978 980 CONTINUE
1979c -- young evolution
1980 IF (nf > 0) THEN
1981 ife=ipm(10+nf,i)
1982 IF(ife /= 0)THEN
1983 ie =npc(ife)
1984 ie2=npc(ife+1)
1985 DO ii = ie+1,ie2-3,2
1986 IF(pld(ii) < pld(ii+2))THEN
1987 CALL ancmsg(msgid=975,
1988 . msgtype=msgerror,
1989 . anmode=aninfo,
1990 . i1=id,
1991 . c1=titr)
1992 EXIT
1993 ENDIF
1994 ENDDO
1995 ENDIF
1996 ENDIF
1997
1998 ENDIF
1999 END DO
2000C----------------------
2001C USER
2002C----------------------
2003 CALL iniguser(bufgeo,igeo,ipm,npc1)
2004C------------------------------------------------------------------
2005C DETONATION POINTS,
2006C DETONATION SEGMENTS,
2007C DETONATION WITH SCREEN,
2008C PLANAR DETONATION WAVE.
2009C------------------------------------------------------------------
2010C Treatment of Matriaux ID (MDET) in Lecdet.f with the flag -like checkout
2011
2012 RETURN
2013C-----
2014 END
2015C
2016!||====================================================================
2017!|| m20dcod ../starter/source/system/fsdcod.F
2018!||--- called by ------------------------------------------------------
2019!|| lectur ../starter/source/starter/lectur.F
2020!||--- calls -----------------------------------------------------
2021!|| ancmsg ../starter/source/output/message/message.F
2022!|| arret ../starter/source/system/arret.F
2023!|| fretitl2 ../starter/source/starter/freform.F
2024!||--- uses -----------------------------------------------------
2025!|| elbuftag_mod ../starter/share/modules1/elbuftag_mod.F
2026!|| message_mod ../starter/share/message_module/message_mod.F
2027!||====================================================================
2028 SUBROUTINE m20dcod(MLAW_TAG, IPM ,PM, MAT_PARAM)
2029C-----------------------------------------------
2030C M o d u l e s
2031C-----------------------------------------------
2032 USE message_mod
2033 USE matparam_def_mod, ONLY : matparam_struct_
2034 USE elbufdef_mod
2035 USE elbuftag_mod
2036 USE names_and_titles_mod , ONLY : nchartitle
2037C-----------------------------------------------
2038C I m p l i c i t T y p e s
2039C-----------------------------------------------
2040#include "implicit_f.inc"
2041C-----------------------------------------------
2042C C o m m o n B l o c k s
2043C-----------------------------------------------
2044#include "com04_c.inc"
2045#include "param_c.inc"
2046#include "scr17_c.inc"
2047C-----------------------------------------------
2048C D u m m y A r g u m e n t s
2049C-----------------------------------------------
2050 TYPE(mlaw_tag_), TARGET, DIMENSION(NUMMAT) :: MLAW_TAG
2051 INTEGER IPM(NPROPMI,NUMMAT)
2052 my_real PM(NPROPM,NUMMAT)
2053 TYPE(MATPARAM_STRUCT_) ,DIMENSION(NUMMAT) ,INTENT(INOUT) :: MAT_PARAM
2054C-----------------------------------------------
2055C L o c a l V a r i a b l e s
2056C-----------------------------------------------
2057 INTEGER I, ILAW, J, K, IS, NF,ILAWk
2058 my_real pun,rho_max
2059 INTEGER ID
2060 CHARACTER(LEN=NCHARTITLE) :: TITR
2061 LOGICAL PASSED
2062 TYPE(MLAW_TAG_), POINTER :: MTAG, MTAGk
2063C-----------------------------------------------
2064 DATA pun/0.1/
2065C-----------------------------------------------
2066C SUBMAT FOR MULTIUMAT LAW20
2067C-----------------------------------------------
2068C
2069 DO i=1,nummat
2070 ilaw=ipm(2,i)
2071 IF(ilaw == 20) THEN
2072 id=ipm(1,i)
2073 CALL fretitl2(titr,ipm(npropmi-ltitr+1,i),ltitr)
2074 nf=nint(pm(40,i))
2075 rho_max=zero
2076 j = 1
2077 DO k=1,2
2078 passed=.true.
2079 is=mat_param(i)%MULTIMAT%MID(k)
2080 IF(is/=0) THEN
2081 DO j=1,nummat
2082 IF(is == ipm(1,j)) THEN
2083 mat_param(i)%MULTIMAT%MID(k)=j
2084 rho_max=max(rho_max,pm(1,j))
2085 GOTO 200
2086 ENDIF
2087 ENDDO
2088 passed=.false.
2089 ENDIF
2090 CALL ancmsg(msgid=128,msgtype=msgerror,anmode=aninfo_blind_1,i1=id,c1=titr,i2=is)
2091 CALL arret(2)
2092 200 CONTINUE !found
2093 !LAW20 material buffer is dimensioned from submaterial buffer dimensions.
2094 IF(passed)THEN
2095 ilawk = ipm(2,j)
2096 mtag => mlaw_tag(i)
2097 mtagk => mlaw_tag(j)
2098 mtag%L_BFRAC= max(mtag%L_BFRAC, mtagk%L_BFRAC)
2099 mtag%L_TEMP = max(mtag%L_TEMP , mtagk%L_TEMP )
2100 mtag%L_PLA = max(mtag%L_PLA , mtagk%L_PLA )
2101 mtag%G_BFRAC= max(mtag%G_BFRAC, mtagk%G_BFRAC)
2102 mtag%G_TEMP = max(mtag%G_TEMP , mtagk%G_TEMP )
2103 mtag%G_PLA = max(mtag%G_PLA , mtagk%G_PLA )
2104 ENDIF
2105 ENDDO !next K
2106 pm(91,i)=rho_max
2107
2108 ELSE IF (ilaw == 151) THEN
2109 id=ipm(1,i)
2110 CALL fretitl2(titr,ipm(npropmi-ltitr+1,i),ltitr)
2111 nf = mat_param(i)%MULTIMAT%NB ! Number of submaterials
2112 rho_max=zero
2113 DO k = 1, nf
2114 is = mat_param(i)%MULTIMAT%MID(k)
2115 DO j = 1, nummat
2116 IF (is == ipm(1, j)) THEN
2117 ipm(20 + k, i) = j
2118 mat_param(i)%MULTIMAT%MID(k) = j
2119 ilawk = ipm(2,j)
2120 mtag => mlaw_tag(i)
2121 mtagk => mlaw_tag(j)
2122 mtag%L_BFRAC= max(mtag%L_BFRAC, mtagk%L_BFRAC)
2123 mtag%L_TB= max(mtag%L_BFRAC, mtagk%L_TB)
2124 mtag%L_TEMP = max(mtag%L_TEMP , mtagk%L_TEMP )
2125 mtag%L_PLA = max(mtag%L_PLA , mtagk%L_PLA )
2126 mtag%G_BFRAC= max(mtag%G_BFRAC, mtagk%G_BFRAC)
2127 mtag%G_TB= max(mtag%G_TB, mtagk%G_TB)
2128 mtag%G_TEMP = max(mtag%G_TEMP , mtagk%G_TEMP )
2129 mtag%G_PLA = max(mtag%G_PLA , mtagk%G_PLA )
2130 rho_max=max(rho_max,pm(1,j))
2131 ENDIF
2132 enddo!next J
2133 pm(91,i)=rho_max
2134 ENDDO
2135 ENDIF
2136 ENDDO !next I=1,NUMMAT
2137
2138 RETURN
2139 END
alpha2
#define alpha2
Definition eval.h:48
fsdcod
subroutine fsdcod(python, bufmat, pm, geo, ibcl, ipres, ibfv, iskew, iskn, sensors, mat_param, itabm1, skew, laccelm, insel, bufgeo, ibcslag, igeo, ipm, ibft, ibcv, ibfvel, ibcr, table, npc1, npc, pld, nom_opt, ibfflux, glob_therm, nimpvel, nimpdisp, nimpacc)
Definition fsdcod.F:46
m20dcod
subroutine m20dcod(mlaw_tag, ipm, pm, mat_param)
Definition fsdcod.F:2029
iniguser
subroutine iniguser(bufgeo, igeo, ipm, npc)
Definition iniguser.F:35
max
#define max(a, b)
Definition macros.h:21
for
for(i8=*sizetab-1;i8 >=0;i8--)
Definition mumps_common.c:91
elbuftag_mod
Definition elbuftag_mod.F:230
intstamp_mod
Definition intstamp_mod.F:38
message_mod
Definition message_mod.F:1257
names_and_titles_mod
Definition names_and_titles_mod.F:1002
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1008
table_mod
Definition table_mod.F:113
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:895
fretitl2
subroutine fretitl2(titr, iasc, l)
Definition freform.F:799
arret
subroutine arret(nn)
Definition arret.F:86
elbuftag_mod::mlaw_tag_
Definition elbuftag_mod.F:235