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=nint(pm(19,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 iexpan = ipm(218,i)
576 IF(iexpan > 0)THEN
577 is=ipm(219,i)
578 IF(is > 0)THEN
579 DO j=1,nfunct
580 IF(is == npc1(j)) THEN
581 ipm(219,i)=j
582 GOTO 299
583 ENDIF
584 ENDDO
585 CALL ancmsg(msgid=126,
586 . msgtype=msgerror,
587 . anmode=aninfo_blind_1,
588 . i1=id,
589 . c1=titr,
590 . i2=is)
591 ENDIF
592 ENDIF
593 299 CONTINUE
594C------------
595C fin boucle sur mats :
596 300 CONTINUE
597
598
599 !---EOS INPUT BASED ON FUNCTION (TABULATED EoS : IEOS=17 ---!
600 DO imat=1,nummat
601 ieos = ipm(4,imat)
602
603 IF(ieos == 17)THEN
604
605 id=ipm(1,imat)
606 CALL fretitl2(titr,ipm(npropmi-ltitr+1,imat),ltitr)
607 ilaw=nint(pm(19,i))
608
609 a_func = pm(35,imat)
610 IF(a_func /= 0)THEN
611 is_found = .false.
612 DO j=1,nfunct
613 IF(a_func == npc1(j)) THEN
614 pm(35,imat)=j
615 is_found = .true.
616 EXIT
617 ENDIF
618 ENDDO
619 IF(.NOT.is_found)CALL ancmsg(msgid=125,msgtype=msgerror,anmode=aninfo_blind_1, i1=id, c1=titr, i2=a_func)
620 ENDIF
621
622 b_func = pm(36,imat)
623 IF(b_func /= 0)THEN
624 is_found = .false.
625 DO j=1,nfunct
626 IF(b_func == npc1(j)) THEN
627 pm(36,imat)=j
628 is_found = .true.
629 EXIT
630 ENDIF
631 ENDDO
632 IF(.NOT.is_found)CALL ancmsg(msgid=125,msgtype=msgerror,anmode=aninfo_blind_1, i1=id, c1=titr, i2=b_func)
633 ENDIF
634
635 ENDIF
636
637 ENDDO
638
639
640C
641C 3) PID SPRING/AIRBAG/GENERAL SPRING
642C
643 DO 420 i=1,numgeo
644C
645 igtyp=igeo(11,i)
646C
647 id=igeo(1,i)
648 CALL fretitl2(titr,igeo(npropgi-ltitr+1,i),ltitr)
649C
650 IF (igtyp == 4) THEN
651C
652 iserv(1)=igeo(101,i)
653 iserv(2)=igeo(102,i)
654 iserv(3)=igeo(103,i)
655 load0 =igeo(101,i)
656 unload0=igeo(103,i)
657 iserv(4)=4
658 iserv(5)=14
659 iserv(6)=18
660 h = geo(7,i)
661 DO 330 k=1,3
662 IF(iserv(k)/=0) THEN
663 DO 320 j=1,nfunct
664 IF(iserv(k) == npc1(j)) THEN
665 geo(iserv(k+3),i)=j+pun
666 igeo(100+k,i)=j
667 GO TO 330
668 ENDIF
669 320 CONTINUE
670 CALL ancmsg(msgid=127,
671 . msgtype=msgerror,
672 . anmode=aninfo_blind_1,
673 . i1=id,
674 . c1=titr,
675 . i2=iserv(k))
676 ENDIF
677 330 CONTINUE
678 IF (igeo(119,i) /=0)THEN
679 errf = 1
680 DO j=1,nfunct
681 IF(igeo(119,i) == npc1(j)) THEN
682 igeo(119,i)=j
683 errf = 0
684 EXIT
685 ENDIF
686 ENDDO
687 IF (errf == 1) THEN
688 CALL ancmsg(msgid=127,
689 . msgtype=msgerror,
690 . anmode=aninfo_blind_1,
691 . i1=id,
692 . c1=titr,
693 . i2=igeo(119,i))
694 ENDIF
695 ENDIF
696 !compute max slope for ifunc3
697 yfac = geo(132,i) !GF3 in lecgeo4
698 ifunc = igeo(119,i) !IFUNC3 in lecgeo4
699 x_scale = geo(18,i)
700 IF (ifunc /= 0)THEN
701 ic1 = npc(ifunc)
702 ic2 = npc(ifunc+1)
703 x0 = pld(ic1)
704 emax = zero
705 DO ii = ic1,ic2-4,2
706 jj = ii+2
707 dx = pld(jj) - x0
708 dy = pld(jj+1) - pld(ii+1)
709 y0 = pld(ii+1)
710 y1 = pld(jj+1)
711 deri = yfac * x_scale * dy / dx
712 x1 = pld(jj)
713 emax = max(emax, deri)
714 x0 = pld(jj)
715 ENDDO
716 geo(141,i) = emax
717 ENDIF
718
719 IF (h == 7)THEN
720 xscale=geo(39,i)
721 load=igeo(101,i)
722 unload=igeo(103,i)
723 np1 = (npc(load+1)-npc(load)) / 2
724 np2 = (npc(unload+1)-npc(unload)) / 2
725 alpha1=zero
726 alpha2=zero
727c IF(NPC(2*NFUNCT+LOAD+1) <0 .OR. NPC(2*NFUNCT+UNLOAD+1) <0)THEN
728 IF(.false.) THEN
729 ! at least one python function
730 ELSE
731 DO 777 j=2,np1
732 j1=2*(j-2)
733 s1=pld(npc(load)+j1)*xscale
734 s2=pld(npc(load)+j1+2)*xscale
735 t1=pld(npc(load)+j1+1)
736 t2=pld(npc(load)+j1+3)
737 ty=zero
738 sx=zero
739 IF ( s1<=zero .AND.s2> zero)alpha1=(t2-t1)/(s2-s1)
740 DO k=2,np2
741 k1=2*(k-2)
742 xx1=pld(npc(unload)+k1)*xscale
743 x2 =pld(npc(unload)+k1+2)*xscale
744 yy1=pld(npc(unload)+k1+1)
745 y2 =pld(npc(unload)+k1+3)
746 IF ( xx1<=zero .AND.x2> zero)alpha2=(y2-yy1)/(x2-xx1)! passage par zero
747 IF (y2>=t1 .AND.yy1<=t2.AND.x2>=s1.AND.xx1<=s2)THEN
748 dydx = (y2-yy1) / (x2-xx1)
749 dtds = (t2-t1) / (s2-s1)
750 IF (dydx > dtds) THEN ! intersection des courbes
751 sx = (t1-yy1-dtds*s1+dydx*xx1) / (dydx-dtds)
752 ty = t1 + dtds*(sx - s1)
753 ENDIF
754 IF (ty/=zero .AND. sx/=zero )THEN
755 IF (ty>=yy1.AND.ty<=y2.AND.sx>=xx1.AND.sx<=x2
756 . .AND.sx>=s2.AND.ty<=t2)THEN
757
758 CALL ancmsg(msgid=982,
759 . msgtype=msgerror,
760 . anmode=aninfo_blind_1,
761 . c1=titr,
762 . i1=unload0,
763 . i2=load0)
764 GOTO 777
765 ENDIF
766 ENDIF
767 ENDIF
768 ENDDO
769 777 CONTINUE
770 IF(alpha2>=alpha1)THEN
771 CALL ancmsg(msgid=982,
772 . msgtype=msgerror,
773 . anmode=aninfo_blind_1,
774 . c1=titr,
775 . i1=unload,
776 . i2=load)
777 ENDIF
778 ENDIF
779 ENDIF
780c-------
781 ELSEIF(igtyp == 12) THEN
782C
783 iserv(1)=igeo(101,i)
784 iserv(2)=igeo(102,i)
785 iserv(3)=igeo(103,i)
786 h = geo(7,i)
787 DO 331 k=1,3
788 IF(iserv(k)/=0) THEN
789 DO j=1,nfunct
790 IF(iserv(k) == npc1(j)) THEN
791 igeo(100+k,i)=j
792 GO TO 331
793 ENDIF
794 ENDDO
795 CALL ancmsg(msgid=127,
796 . msgtype=msgerror,
797 . anmode=aninfo_blind_1,
798 . i1=id,
799 . c1=titr,
800 . i2=iserv(k))
801 ENDIF
802 331 CONTINUE
803 IF (igeo(201,i) > 0) THEN
804 DO j=1,ntable
805 IF (igeo(201,i) == table(j)%NOTABLE) THEN
806 igeo(201,i) = j
807 GOTO 332
808 ENDIF
809 END DO
810 CALL ancmsg(msgid=779,
811 . msgtype=msgerror,
812 . anmode=aninfo,
813 . i1=id,
814 . c1=titr,
815 . i2=itable)
816 ENDIF
817 332 CONTINUE
818c
819 IF (igeo(119,i) /=0)THEN
820 errf = 1
821 DO j=1,nfunct
822 IF(igeo(119,i) == npc1(j)) THEN
823 igeo(119,i)=j
824 errf = 0
825 EXIT
826 ENDIF
827 ENDDO
828 IF (errf == 1) THEN
829 CALL ancmsg(msgid=127,
830 . msgtype=msgerror,
831 . anmode=aninfo_blind_1,
832 . i1=id,
833 . c1=titr,
834 . i2=igeo(119,i))
835 ENDIF
836 ENDIF
837
838 yfac = geo(132,i) !GF3 in lecgeo12
839 ifunc = igeo(119,i) !IFUNC3 in lecgeo12
840 x_scale = geo(18,i)
841 IF (ifunc /= 0)THEN
842 ic1 = npc(ifunc)
843 ic2 = npc(ifunc+1)
844 x0 = pld(ic1)
845 emax = zero
846 DO ii = ic1,ic2-4,2
847 jj = ii+2
848 dx = pld(jj) - x0
849 dy = pld(jj+1) - pld(ii+1)
850 y0 = pld(ii+1)
851 y1 = pld(jj+1)
852 deri = yfac * x_scale * dy / dx
853 x1 = pld(jj)
854 emax = max(emax, deri)
855 x0 = pld(jj)
856 ENDDO
857 geo(141,i) = emax ! slope max
858 ENDIF
859
860 IF (h == 7)THEN
861 xscale=geo(39,i)
862 load=igeo(101,i)
863 unload=igeo(103,i)
864 np1 = (npc(load+1)-npc(load)) / 2
865 np2 = (npc(unload+1)-npc(unload)) / 2
866 alpha1=zero
867 alpha2=zero
868c IF(NPC(2*NFUNCT+LOAD+1) <0 .OR. NPC(2*NFUNCT+UNLOAD+1) <0)THEN
869 IF(.false.) THEN
870 ! at least one python function
871 ELSE
872
873c---
874 DO 778 j=2,np1
875 j1=2*(j-2)
876 s1=pld(npc(load)+j1)*xscale
877 s2=pld(npc(load)+j1+2)*xscale
878 t1=pld(npc(load)+j1+1)
879 t2=pld(npc(load)+j1+3)
880 ty=zero
881 sx=zero
882 IF ( s1<=zero .AND.s2> zero)alpha1=(t2-t1)/(s2-s1)
883 DO k=2,np2
884 k1=2*(k-2)
885 xx1=pld(npc(unload)+k1)*xscale
886 x2=pld(npc(unload)+k1+2)*xscale
887 yy1=pld(npc(unload)+k1+1)
888 y2=pld(npc(unload)+k1+3)
889 IF ( xx1<=zero .AND.x2> zero)alpha2=(y2-yy1)/(x2-xx1)
890 IF (y2>=t1 .AND.yy1<=t2.AND.x2>=s1.AND.xx1<=s2)THEN
891 dydx = (y2-yy1) / (x2-xx1)
892 dtds = (t2-t1) / (s2-s1)
893 IF (dydx > dtds) THEN
894 sx = (t1-yy1-dtds*s1+dydx*xx1) / (dydx-dtds)
895 ty = t1 + dtds*(sx - s1)
896 ENDIF
897 IF (ty/=zero .AND. sx/=zero )THEN
898 IF (ty>=yy1.AND.ty<=y2.AND.sx>=xx1.AND.sx<=x2
899 . .AND.sx>=s2.AND.ty<=t2)THEN
900 CALL ancmsg(msgid=982,
901 . msgtype=msgerror,
902 . anmode=aninfo_blind_1,
903 . c1=titr,
904 . i1=unload,
905 . i2=load)
906 GOTO 778
907 ENDIF
908 ENDIF
909 ENDIF
910 ENDDO
911 778 CONTINUE
912 IF(alpha2>=alpha1)THEN
913 CALL ancmsg(msgid=982,
914 . msgtype=msgerror,
915 . anmode=aninfo_blind_1,
916 . c1=titr,
917 . i1=unload,
918 . i2=load)
919 ENDIF
920 ENDIF
921 ENDIF
922C
923 ELSE IF(igtyp == 7) THEN
924C
925 iserv(1)=nint(geo(19,i))
926 iserv(2)=nint(geo(44,i))
927 iserv(3)=19
928 iserv(4)=44
929 DO 360 k=1,2
930 DO 340 j=1,nfunct
931 IF(iserv(k) == npc1(j)) THEN
932 geo(iserv(k+2),i)=j+pun
933 GO TO 360
934 ENDIF
935 340 CONTINUE
936 CALL ancmsg(msgid=127,
937 . msgtype=msgerror,
938 . anmode=aninfo_blind_1,
939 . i1=id,
940 . c1=titr,
941 . i2=iserv(k))
942 360 CONTINUE
943c------------------------
944 ELSEIF(igtyp==8.OR.igtyp==13) THEN
945C
946 DO 400 j=1,6
947 iserv(1)=igeo(101+3*(j-1),i)
948 iserv(2)=igeo(102+3*(j-1),i)
949 iserv(3)=igeo(103+3*(j-1),i)
950 iflag1 = 0
951 iflag2 = 0
952 iflag3 = 0
953 IF(iserv(1) == 0)iflag1=1
954 IF(iserv(2) == 0)iflag2=1
955 IF(iserv(3) == 0)iflag3=1
956 IF(iflag1+iflag2+iflag3 == 3)GOTO 400
957 DO 380 k=1,nfunct
958 IF(iserv(1) == npc1(k)) THEN
959 igeo(101+3*(j-1),i) = k
960 iflag1=1
961 ENDIF
962 IF(iserv(2) == npc1(k)) THEN
963 igeo(102+3*(j-1),i) = k
964 iflag2=1
965 ENDIF
966 IF(iserv(3) == npc1(k)) THEN
967 igeo(103+3*(j-1),i) = k
968 iflag3=1
969 ENDIF
970 IF(iflag1+iflag2+iflag3 == 3)GOTO 400
971 380 CONTINUE
972
973 IF(iflag1 == 0) id1=iserv(1)
974 IF(iflag2 == 0) id1=iserv(2)
975 IF(iflag3 == 0) id1=iserv(3)
976 CALL ancmsg(msgid=127,
977 . msgtype=msgerror,
978 . anmode=aninfo_blind_1,
979 . i1=id,
980 . c1=titr,
981 . i2=id1)
982 400 CONTINUE
983c --------
984 DO j=1, 6
985 errf = 1
986 IF (igeo(119+j-1,i) /=0)THEN
987 DO k=1,nfunct
988 IF(igeo(119+j-1,i) == npc1(k)) THEN !ifunc3
989 igeo(119+j-1,i) = k
990 errf = 0
991 EXIT
992 ENDIF
993 ENDDO
994 IF (errf == 1)THEN
995 IF (igtyp == 8)THEN
996 ELSE
997 ENDIF
998 CALL ancmsg(msgid=127,
999 . msgtype=msgerror,
1000 . anmode=aninfo_blind_1,
1001 . i1=id,
1002 . c1=titr,
1003 . i2=igeo(119+j-1,i))
1004 ENDIF
1005 ENDIF
1006 ENDDO
1007!compute max slope for ifunc3
1008 DO j=1, 6
1009 yfac = geo(131+j,i) !GF3 in lecgeo13 -8
1010 ifunc = igeo(118+j,i) !IFUNC3 in lecgeo13 -8
1011 x_scale=geo(44+4*(j-1),i)
1012 IF (ifunc /= 0)THEN
1013 ic1 = npc(ifunc)
1014 ic2 = npc(ifunc+1)
1015 x0 = pld(ic1)
1016 emax = zero
1017 DO ii = ic1,ic2-4,2
1018 jj = ii+2
1019 dx = pld(jj) - x0
1020 dy = pld(jj+1) - pld(ii+1)
1021 y0 = pld(ii+1)
1022 y1 = pld(jj+1)
1023 deri = yfac * x_scale * dy / dx
1024 x1 = pld(jj)
1025 emax = max(emax, deri)
1026 x0 = pld(jj)
1027 ENDDO
1028 geo(140+j,i) = emax ! max slope for ifunc3
1029 ENDIF
1030 ENDDO
1031C
1032 DO 877 j=1, 6
1033 IF(j<= 2)THEN
1034 h=geo(7*j,i)
1035 ELSE
1036 h=geo(14+(j-2)*4,i)
1037 ENDIF
1038 IF (h == 7)THEN
1039 IF (j==1)THEN
1040 xscale=geo(39,i)
1041 ELSE
1042 xscale=geo(172+j,i)
1043 ENDIF
1044 load=igeo(101+3*(j-1),i)
1045 unload=igeo(103+3*(j-1),i)
1046 np1 = (npc(load+1)-npc(load))*half
1047 np2 = (npc(unload+1)-npc(unload))*half
1048 alpha1=zero
1049 alpha2=zero
1050c IF(NPC(2*NFUNCT+LOAD+1) <0 .OR. NPC(2*NFUNCT+UNLOAD+1) <0)THEN
1051 IF(.false.) THEN
1052 ! at least one python function
1053 ELSE
1054
1055c---
1056 DO jj=2,np1
1057 j1=2*(jj-2)
1058 s1=pld(npc(load)+j1)*xscale
1059 s2=pld(npc(load)+j1+2)*xscale
1060 t1=pld(npc(load)+j1+1)
1061 t2=pld(npc(load)+j1+3)
1062 ty=zero
1063 sx=zero
1064 IF ( s1<=zero .AND.s2> zero)alpha1=(t2-t1)/(s2-s1)
1065 DO k=2,np2
1066 k1=2*(k-2)
1067 xx1=pld(npc(unload)+k1)*xscale
1068 x2=pld(npc(unload)+k1+2)*xscale
1069 yy1=pld(npc(unload)+k1+1)
1070 y2=pld(npc(unload)+k1+3)
1071 IF ( xx1<=zero .AND.x2> zero)alpha2=(y2-yy1)/(x2-xx1)
1072 IF (y2>=t1 .AND.yy1<=t2.AND.x2>=s1.AND.xx1<=s2)THEN
1073 dydx = (y2-yy1) / (x2-xx1)
1074 dtds = (t2-t1) / (s2-s1)
1075 IF (dydx > dtds) THEN
1076 sx = (t1-yy1-dtds*s1+dydx*xx1) / (dydx-dtds)
1077 ty = t1 + dtds*(sx - s1)
1078 ENDIF
1079 IF (ty/=zero .AND. sx/=zero )THEN
1080 IF (ty>=yy1.AND.ty<=y2.AND.sx>=xx1.AND.sx<=x2
1081 . .AND.sx>=s2.AND.ty<=t2)THEN
1082 IF (igtyp == 8)THEN
1083 ELSE
1084 ENDIF
1085 CALL ancmsg(msgid=982,
1086 . msgtype=msgerror,
1087 . anmode=aninfo_blind_1,
1088 . c1=titr,
1089 . i1=unload,
1090 . i2=load)
1091 GOTO 877
1092 ENDIF
1093 ENDIF
1094 ENDIF
1095 ENDDO
1096 ENDDO
1097 IF(alpha2>=alpha1)THEN
1098 IF (igtyp == 8)THEN
1099 ELSE
1100 ENDIF
1101 CALL ancmsg(msgid=982,
1102 . msgtype=msgerror,
1103 . anmode=aninfo_blind_1,
1104 . c1=titr,
1105 . i1=unload,
1106 . i2=load)
1107 ENDIF
1108 ENDIF
1109 ENDIF
1110 877 CONTINUE
1111
1112C ENDDO
1113c --------
1114C
1115 ELSEIF (igtyp==25) THEN
1116C
1117 DO 401 j=1,4 ! instead of 6 pmo
1118 iserv(1)=igeo(102+4*(j-1),i)
1119 iserv(2)=igeo(103+4*(j-1),i)
1120 iserv(3)=igeo(104+4*(j-1),i)
1121 iflag1 = 0
1122 iflag2 = 0
1123 iflag3 = 0
1124 IF(iserv(1) == 0)iflag1=1
1125 IF(iserv(2) == 0)iflag2=1
1126 IF(iserv(3) == 0)iflag3=1
1127 IF(iflag1+iflag2+iflag3 == 3)GOTO 401
1128 DO 381 k=1,nfunct
1129 IF(iserv(1) == npc1(k)) THEN
1130 igeo(102+4*(j-1),i) = k
1131 iflag1=1
1132 ENDIF
1133 IF(iserv(2) == npc1(k)) THEN
1134 igeo(103+4*(j-1),i) = k
1135 iflag2=1
1136 ENDIF
1137 IF(iserv(3) == npc1(k)) THEN
1138 igeo(104+4*(j-1),i) = k
1139 iflag3=1
1140 ENDIF
1141 IF(iflag1+iflag2+iflag3 == 3)GOTO 401
1142 381 CONTINUE
1143 IF(iflag1 == 0) id1=iserv(1)
1144 IF(iflag2 == 0) id1=iserv(2)
1145 IF(iflag3 == 0) id1=iserv(3)
1146 CALL ancmsg(msgid=127,
1147 . msgtype=msgerror,
1148 . anmode=aninfo_blind_1,
1149 . i1=id,
1150 . c1=titr,
1151 . i2=id1)
1152 401 CONTINUE
1153C
1154c --------
1155 DO j=1,4
1156 errf = 1
1157 IF (igeo(119+j-1,i) /=0)THEN
1158 DO k=1,nfunct
1159 IF(igeo(119+j-1,i) == npc1(k)) THEN
1160 igeo(119+j-1,i) = k
1161 errf = 0
1162 EXIT
1163 ENDIF
1164 ENDDO
1165 IF (errf == 1)THEN
1166 CALL ancmsg(msgid=127,
1167 . msgtype=msgerror,
1168 . anmode=aninfo_blind_1,
1169 . i1=id,
1170 . c1=titr,
1171 . i2=igeo(119+j-1,i))
1172 ENDIF
1173 ENDIF
1174 ENDDO
1175!compute max slope for ifunc3
1176 DO j=1, 4
1177 yfac = geo(131+j,i) !GF3 in lecgeo25
1178 ifunc = igeo(118+j,i) !IFUNC3 in lecgeo25
1179 IF (j==1) x_scale = geo(44,i)
1180 IF (j==2) x_scale = geo(48,i)
1181 IF (j==3) x_scale = geo(56,i)
1182 IF (j==4) x_scale = geo(60,i)
1183 IF (ifunc /= 0)THEN
1184 ic1 = npc(ifunc)
1185 ic2 = npc(ifunc+1)
1186 x0 = pld(ic1)
1187 emax = zero
1188 DO ii = ic1,ic2-4,2
1189 jj = ii+2
1190 dx = pld(jj) - x0
1191 dy = pld(jj+1) - pld(ii+1)
1192 y0 = pld(ii+1)
1193 y1 = pld(jj+1)
1194 deri = yfac * x_scale * dy / dx
1195 x1 = pld(jj)
1196 emax = max(emax, deri)
1197 x0 = pld(jj)
1198 ENDDO
1199 geo(140+j,i) = emax
1200 ENDIF
1201 ENDDO
1202
1203 DO 888 j=1,4
1204 h=igeo(101+(j-1)*4,i)
1205 IF (h == 7)THEN
1206 IF (j==1)THEN
1207 xscale=geo(39,i)
1208 ELSEIF (j==2)THEN
1209 xscale=geo(174,i)
1210 ELSEIF (j==3)THEN
1211 xscale=geo(176,i)
1212 ELSEIF (j==4)THEN
1213 xscale=geo(177,i)
1214 ENDIF
1215 load=igeo(102+4*(j-1),i)
1216 unload=igeo(103+4*(j-1),i)
1217 np1 = (npc(load+1)-npc(load))*half
1218 np2 = (npc(unload+1)-npc(unload))*half
1219 alpha1=zero
1220 alpha2=zero
1221C IF(NPC(2*NFUNCT+LOAD+1) <0 .OR. NPC(2*NFUNCT+UNLOAD+1) <0)THEN
1222 IF(.false.) THEN
1223 ! at least one python function
1224 ELSE
1225c---
1226 DO jj=2,np1
1227 j1=2*(jj-2)
1228 s1=pld(npc(load)+j1)*xscale
1229 s2=pld(npc(load)+j1+2)*xscale
1230 t1=pld(npc(load)+j1+1)
1231 t2=pld(npc(load)+j1+3)
1232 ty=zero
1233 sx=zero
1234 IF ( s1<=zero .AND.s2> zero)alpha1=(t2-t1)/(s2-s1)
1235 DO k=2,np2
1236 k1=2*(k-2)
1237 xx1=pld(npc(unload)+k1)*xscale
1238 x2=pld(npc(unload)+k1+2)*xscale
1239 yy1=pld(npc(unload)+k1+1)
1240 y2=pld(npc(unload)+k1+3)
1241 IF ( xx1<=zero .AND.x2> zero)alpha2=(y2-yy1)/(x2-xx1)
1242 IF (y2>=t1 .AND.yy1<=t2.AND.x2>=s1.AND.xx1<=s2)THEN
1243 dydx = (y2-yy1) / (x2-xx1)
1244 dtds = (t2-t1) / (s2-s1)
1245 IF (dydx > dtds) THEN
1246 sx = (t1-yy1-dtds*s1+dydx*xx1) / (dydx-dtds)
1247 ty = t1 + dtds*(sx - s1)
1248 ENDIF
1249 IF (ty/=zero .AND. sx/=zero )THEN
1250 IF (ty>=yy1.AND.ty<=y2.AND.sx>=xx1.AND.sx<=x2
1251 . .AND.sx>=s2.AND.ty<=t2)THEN
1252 CALL ancmsg(msgid=982,
1253 . msgtype=msgerror,
1254 . anmode=aninfo_blind_1,
1255 . c1=titr,
1256 . i1=unload,
1257 . i2=load)
1258 GOTO 888
1259 ENDIF
1260 ENDIF
1261 ENDIF
1262 ENDDO
1263 ENDDO
1264 IF(alpha2>=alpha1)THEN
1265 CALL ancmsg(msgid=982,
1266 . msgtype=msgerror,
1267 . anmode=aninfo_blind_1,
1268 . c1=titr,
1269 . i1=unload,
1270 . i2=load)
1271 ENDIF
1272 ENDIF
1273 ENDIF ! H == 7
1274 888 CONTINUE
1275c --------
1276 ELSEIF (igtyp == 26) THEN
1277 nfunc = igeo(20,i)
1278 nfund = igeo(21,i)
1279 iadd = 100
1280 DO k=1,nfunc
1281 iflag1 = 0
1282 DO j=1,nfunct
1283 IF (igeo(iadd+k,i) == npc1(j)) THEN
1284 igeo(iadd+k,i) = j
1285 iflag1 = 1
1286 EXIT
1287 ENDIF
1288 ENDDO
1289 IF (iflag1 == 0) THEN
1290 ENDIF
1291 ENDDO
1292 iadd = nfunc+100
1293 DO k=1,nfund
1294 iflag1 = 0
1295 DO j=1,nfunct
1296 IF (igeo(iadd+k,i) == npc1(j)) THEN
1297 igeo(iadd+k,i) = j
1298 iflag1 = 1
1299 EXIT
1300 ENDIF
1301 ENDDO
1302 IF (iflag1 == 0) THEN
1303 ENDIF
1304 ENDDO
1305
1306 ELSEIF (igtyp == 27) THEN
1307C
1308 ! Convert User ID function in internal ID
1309 iserv(1) = igeo(101,i)
1310 iserv(2) = igeo(102,i)
1311 iserv(3) = 4
1312 iserv(4) = 14
1313 DO k=1,2
1314 iflag1 = 0
1315 IF (iserv(k) /= 0) THEN
1316 DO j=1,nfunct
1317 IF (iserv(k) == npc1(j)) THEN
1318 geo(iserv(k+2),i) = j+pun
1319 igeo(100+k,i) = j
1320 iflag1 = 1
1321 EXIT
1322 ENDIF
1323 ENDDO
1324 IF (iflag1 == 0) THEN
1325 CALL ancmsg(msgid=127,
1326 . msgtype=msgerror,
1327 . anmode=aninfo_blind_1,
1328 . i1=id,
1329 . c1=titr,
1330 . i2=iserv(k+2))
1331 ENDIF
1332 ENDIF
1333 ENDDO
1334 ! Compute max slop for damping
1335 ifunc = igeo(102,i)
1336 IF (ifunc /= 0)THEN
1337 yfac = geo(132,i)
1338 x_scale = geo(18,i)
1339 ic1 = npc(ifunc)
1340 ic2 = npc(ifunc+1)
1341 x0 = pld(ic1)
1342 emax = zero
1343 DO ii = ic1,ic2-4,2
1344 jj = ii+2
1345 dx = pld(jj) - x0
1346 dy = pld(jj+1) - pld(ii+1)
1347 y0 = pld(ii+1)
1348 y1 = pld(jj+1)
1349 deri = yfac * x_scale * dy / dx
1350 x1 = pld(jj)
1351 emax = max(emax,deri)
1352 x0 = pld(jj)
1353 ENDDO
1354 geo(141,i) = emax
1355 ENDIF
1356 ENDIF
1357C
1358 420 CONTINUE
1359
1360C
1361C
1362C 4) CONCENTRATED LOADS
1363C
1364 DO 460 i=1,nconld-npreld
1365 DO 440 j=1,nfunct
1366 IF(ibcl(3,i) == npc1(j)) THEN
1367 ibcl(3,i)=j
1368 GOTO 460
1369 ENDIF
1370 440 CONTINUE
1371 CALL ancmsg(msgid=120,
1372 . msgtype=msgerror,
1373 . anmode=aninfo_blind_1,
1374 . c1='CONCENTRED LOADS',
1375 . i1=ibcl(3,i))
1376 460 CONTINUE
1377C
1378C 5) PRESSURE LOADS
1379C
1380 DO 500 i=1,npreld
1381 DO 480 j=1,nfunct
1382 IF(ipres(5,i) == npc1(j)) THEN
1383 ipres(5,i)=j
1384 GO TO 500
1385 ENDIF
1386 480 CONTINUE
1387 CALL ancmsg(msgid=120,
1388 . msgtype=msgerror,
1389 . anmode=aninfo_blind_1,
1390 . c1='PRESSURE LOADS',
1391 . i1=ipres(5,i))
1392 500 CONTINUE
1393C
1394C 6) FIXED DISPLACEMENTS
1395C
1396
1397 DO i=1,nimpdisp
1398 ok = 0
1399 DO j=1,nfunct
1400 IF(ibfv(3,i) == npc1(j)) THEN
1401 ibfv(3,i)=j
1402 ok = 1
1403 EXIT
1404 END IF
1405 END DO
1406
1407 IF (ok == 0) THEN
1408 CALL ancmsg(msgid=120,
1409 . msgtype=msgerror,
1410 . anmode=aninfo_blind_1,
1411 . c1='IMPOSED DISPLACEMENTS',
1412 . i1=ibfv(3,i))
1413 END IF
1414 END DO
1415c
1416 DO i=1,nimpdisp
1417 ok = 0
1418 DO j=1,nfunct
1419 IF (ibfv(15,i)== 0) THEN
1420 ok = 1
1421 EXIT
1422 ELSE
1423 IF(ibfv(15,i) == npc1(j)) THEN
1424 ibfv(15,i)=j
1425 ok = 1
1426 EXIT
1427 ENDIF
1428 ENDIF
1429 END DO
1430 IF (ok == 0) THEN
1431 CALL ancmsg(msgid=120,
1432 . msgtype=msgerror,
1433 . anmode=aninfo_blind_1,
1434 . c1='IMPOSED DISPLACEMENTS',
1435 . i1=ibfv(3,i))
1436 END IF
1437 END DO
1438C
1439C 7) FIXED VELOCITIES
1440C
1441 DO i=1+nimpdisp,nimpvel+nimpdisp
1442 ok = 0
1443 DO j=1,nfunct
1444 IF(ibfv(3,i) == npc1(j)) THEN
1445 ibfv(3,i)=j
1446 ok = 1
1447 EXIT
1448 END IF
1449 END DO
1450 IF (ok == 0) THEN
1451 CALL ancmsg(msgid=120,
1452 . msgtype=msgerror,
1453 . anmode=aninfo_blind_1,
1454 . c1='IMPOSED VELOCITIES',
1455 . i1=ibfv(3,i))
1456 END IF
1457 END DO
1458c
1459 DO i=1+nimpdisp,nimpvel+nimpdisp
1460 ok = 0
1461 DO j=1,nfunct
1462 IF (ibfv(15,i)== 0) THEN
1463 ok = 1
1464 EXIT
1465 ELSE
1466 IF(ibfv(15,i) == npc1(j)) THEN
1467 ibfv(15,i)=j
1468 ok = 1
1469 EXIT
1470 END IF
1471 END IF
1472 END DO
1473 IF(ok == 0) THEN
1474 CALL ancmsg(msgid=120,
1475 . msgtype=msgerror,
1476 . anmode=aninfo_blind_1,
1477 . c1='IMPOSED VELOCITIES',
1478 . i1=ibfv(3,i))
1479 END IF
1480 END DO
1481C
1482C 8) FIXED ACCELERATIONS
1483C
1484 DO i=1+nimpvel+nimpdisp,nimpacc+nimpvel+nimpdisp
1485 ok = 0
1486 DO j=1,nfunct
1487 IF(ibfv(3,i) == npc1(j)) THEN
1488 ibfv(3,i)=j
1489 ok = 1
1490 EXIT
1491 END IF
1492 END DO
1493
1494 IF (ok == 0) THEN
1495 CALL ancmsg(msgid=120,
1496 . msgtype=msgerror,
1497 . anmode=aninfo_blind_1,
1498 . c1='IMPOSED ACCELERATIONS',
1499 . i1=ibfv(3,i))
1500 END IF
1501 END DO
1502c
1503 DO i=1+nimpvel+nimpdisp,nimpacc+nimpvel+nimpdisp
1504 ok = 0
1505 DO j=1,nfunct
1506 IF (ibfv(15,i)== 0) THEN
1507 ok = 1
1508 EXIT
1509 ELSE
1510 IF(ibfv(15,i) == npc1(j)) THEN
1511 ibfv(15,i)=j
1512 ok = 1
1513 EXIT
1514 ENDIF
1515 ENDIF
1516 END DO
1517 IF (ok == 0) THEN
1518 CALL ancmsg(msgid=120,
1519 . msgtype=msgerror,
1520 . anmode=aninfo_blind_1,
1521 . c1='IMPOSED ACCELERATIONS',
1522 . i1=ibfv(3,i))
1523 END IF
1524 END DO
1525C=======================================================================
1526C
1527C (II) SKEW
1528C
1529C=======================================================================
1530C
1531C 1) BOUNDARY CONDITIONS
1532C
1533c DO 660 I=1,NUMNOD
1534c DO 640 J=0,NUMSKW
1535c IF(ISKEW(I) == ISKN(4,J+1)) THEN
1536c ISKEW(I)=J+1
1537c GO TO 660
1538c ENDIF
1539c 640 CONTINUE
1540c CALL ANSTCKC(19,'BOUNDARY CONDITIONS')
1541c CALL ANSTCKI(ISKEW(I))
1542c CALL ANCERR(137,ANINFO_BLIND_1)
1543c 660 CONTINUE
1544C
1545C 2) CONCENTRATED LOADS
1546C
1547c DO 700 I=1,NCONLD-NPRELD
1548c IS=IBCL(2,I)/10
1549c DO 680 J=0,NUMSKW
1550c IF(IS == ISKN(4,J+1)) THEN
1551c IBCL(2,I)=(J+1)*10+MOD(IBCL(2,I),10)
1552c GO TO 700
1553c ENDIF
1554c 680 CONTINUE
1555c CALL ANSTCKC(18,'CONCENTRATED LOADS')
1556c CALL ANSTCKI(IS)
1557c CALL ANCERR(137,ANINFO_BLIND_1)
1558c 700 CONTINUE
1559
1560
1561C
1562C 3) FIXED VELOCITIES
1563C
1564c DO 745 I=1,NFXVEL
1565c IF (IBFV(9,I)>0) THEN
1566c IS=IBFV(9,I)
1567c JJ=(NUMSKW+1)+MIN(IUN,NSPCOND)*NUMSPH+1
1568c DO J=1,NUMFRAM
1569c JJ = JJ+1
1570c IF(IS == ISKN(4,JJ)) THEN
1571c IBFV(9,I)=J+1
1572c GO TO 745
1573c ENDIF
1574c ENDDO
1575c ELSE
1576c IS=IBFV(2,I)/10
1577c DO J=0,NUMSKW
1578c IF(IS == ISKN(4,J+1)) THEN
1579c IBFV(2,I)=(J+1)*10+MOD(IBFV(2,I),10)
1580c GO TO 745
1581c ENDIF
1582c ENDDO
1583c ENDIF
1584c CALL ANSTCKC(18,'IMPOSED VELOCITIES')
1585c CALL ANSTCKI(IS)
1586c CALL ANCERR(137,ANINFO_BLIND_1)
1587c 745 CONTINUE
1588
1589
1590C---------------------------
1591C 9) FIXED temperatures
1592C---------------------------
1593 DO 751 i=1,glob_therm%NFXTEMP
1594 DO 750 j=1,nfunct
1595 IF(ibft(2,i) == npc1(j)) THEN
1596 ibft(2,i)=j
1597 GOTO 751
1598 ENDIF
1599 750 CONTINUE
1600 CALL ancmsg(msgid=120,
1601 . msgtype=msgerror,
1602 . anmode=aninfo_blind_1,
1603 . c1='IMPOSED TEMPERATURE',
1604 . i1=ibft(2,i))
1605 751 CONTINUE
1606C------------------------------
1607C 10 FIXED convective flux
1608C------------------------------
1609 DO 753 i=1,glob_therm%NUMCONV
1610 DO 752 j=1,nfunct
1611 IF(ibcv(5,i) == npc1(j)) THEN
1612 ibcv(5,i)=j
1613 GOTO 753
1614 ENDIF
1615 752 CONTINUE
1616 CALL ancmsg(msgid=120,
1617 . msgtype=msgerror,
1618 . anmode=aninfo_blind_1,
1619 . c1='FIXED FLUX',
1620 . i1=ibcv(5,i))
1621 753 CONTINUE
1622C-----------------------------
1623C 11) FIXED radiative flux
1624C-----------------------------
1625 DO 755 i=1,glob_therm%NUMRADIA
1626 DO 754 j=1,nfunct
1627 IF(ibcr(5,i) == npc1(j)) THEN
1628 ibcr(5,i)=j
1629 GOTO 755
1630 ENDIF
1631 754 CONTINUE
1632 CALL ancmsg(msgid=120,
1633 . msgtype=msgerror,
1634 . anmode=aninfo_blind_1,
1635 . c1='FIXED RADIATIVE FLUX',
1636 . i1=ibcr(5,i))
1637 755 CONTINUE
1638C---------------------------
1639C 12) FIXED heat flux
1640C---------------------------
1641 DO 757 i=1,glob_therm%NFXFLUX
1642 DO 756 j=1,nfunct
1643 IF(ibfflux(5,i) == npc1(j)) THEN
1644 ibfflux(5,i)=j
1645 GOTO 757
1646 ENDIF
1647 756 CONTINUE
1648 CALL ancmsg(msgid=120,
1649 . msgtype=msgerror,
1650 . anmode=aninfo_blind_1,
1651 . c1='FIXED HEAT FLUX',
1652 . i1=ibfflux(5,i))
1653 757 CONTINUE
1654
1655
1656C
1657c 4) PID SOLID, GENERAL SPRING, POROUS MEDIUM
1658C
1659c DO 780 I=1,NUMGEO
1660c IGTYP=IGEO(11,I)
1661c IF (IGTYP == 6 .OR. IGTYP == 21 .OR. IGTYP == 22) THEN
1662c IS=-IGEO(2,I)
1663c IF(IS>=0) THEN
1664c DO K=0,NUMSKW
1665c IF(IS == ISKN(4,K+1)) THEN
1666c IGEO(2,I)=-(K+1)
1667c GO TO 780
1668c ENDIF
1669c ENDDO
1670c CALL ANSTCKC(17,'ORTHOTROPIC SOLID')
1671c CALL ANSTCKI(IS)
1672c CALL ANCERR(137,ANINFO_BLIND_1)
1673c ENDIF
1674c ELSEIF(IGTYP == 34)THEN
1675c IS=NINT(GEO(2,I))
1676c IF (IS/=0)THEN
1677c DO 758 K=0,NUMSKW
1678c IF(IS == ISKN(4,K+1)) THEN
1679c GEO(2,I)=(K+1)+PUN
1680c IGEO(2,I)=K+1
1681c GO TO 780
1682c ENDIF
1683c 758 CONTINUE
1684c
1685c CALL ANSTCKC(18,'GENERAL SPH PID')
1686c CALL ANSTCKI(IS)
1687c CALL ANCERR(137,ANINFO_BLIND_1)
1688c ENDIF
1689
1690c ELSEIF(IGTYP == 8.OR.IGTYP == 13.OR.IGTYP == 25.OR.
1691c . (IGTYP>=29.AND.IGTYP<50)) THEN
1692c IS=IGEO(2,I)
1693c DO 760 K=0,NUMSKW
1694c IF(IS == ISKN(4,K+1)) THEN
1695c GEO(2,I)=(K+1)+PUN
1696c IGEO(2,I)=K+1
1697c GO TO 780
1698c ENDIF
1699c 760 CONTINUE
1700c CALL ANSTCKC(18,'GENERAL SPRING PID')
1701c CALL ANSTCKI(IS)
1702c CALL ANCERR(137,ANINFO_BLIND_1)
1703c ELSEIF(IGTYP == 15)THEN
1704c IS=NINT(GEO(27,I))
1705c DO 765 K=0,NUMSKW
1706c IF(IS == ISKN(4,K+1)) THEN
1707c GEO(27,I)=(K+1)+PUN
1708c GO TO 780
1709c ENDIF
1710c 765 CONTINUE
1711c CALL ANSTCKC(17,'POROUS MEDIUM PID')
1712c CALL ANSTCKI(IS)
1713c CALL ANCERR(137,ANINFO_BLIND_1)
1714c ENDIF
1715c 780 CONTINUE
1716C
1717C 5) RIGID BODIES
1718C
1719c DO 810 I=1,NRBYKIN
1720c IS = NPBY(9,I)
1721c DO 800 J=0,NUMSKW
1722c IF(IS == ISKN(4,J+1)) THEN
1723c NPBY(9,I)=J+1
1724c GO TO 810
1725c ENDIF
1726c 800 CONTINUE
1727c CALL ANSTCKC(12,'RIGID BODIES')
1728c CALL ANSTCKI(IS)
1729c CALL ANCERR(137,ANINFO_BLIND_1)
1730c 810 CONTINUE
1731C
1732C 5) ACCELEROMETER
1733C
1734c DO 850 I=1,NACCELM
1735c IS=LACCELM(3,I)
1736c IF(LACCELM(1,I) > 0) THEN
1737c DO J=0,NUMSKW
1738c IF(IS == ISKN(4,J+1)) THEN
1739c LACCELM(3,I)=J+1
1740c GO TO 850
1741c ENDIF
1742c ENDDO
1743c CALL ANSTCKC(13,'ACCELEROMETER')
1744c CALL ANSTCKI(IS)
1745c CALL ANCERR(137,ANINFO_BLIND_1)
1746c ENDIF
1747c 850 CONTINUE
1748c DO 880 I=1,NBCSLAG
1749c IS=IBCSLAG(4,I)
1750c DO J=0,NUMSKW
1751c IF(IS == ISKN(4,J+1)) THEN
1752c IBCSLAG(4,I)=J+1
1753c GO TO 880
1754c ENDIF
1755c ENDDO
1756c CALL ANSTCKC(36,'BOUNDARY CONDITIONS WITH LAGR. MULT.')
1757c CALL ANSTCKI(IS)
1758c CALL ANCERR(137,ANINFO_BLIND_1)
1759c 880 CONTINUE
1760C
1761C GRAVITY
1762c DO 890 I=1,NGRAV
1763c NOSKEW=IGRV(2,I)/10
1764c ND =IGRV(2,I)-10*NOSKEW
1765c DO 895 J=0,NUMSKW
1766c IF(NOSKEW == ISKN(4,J+1)) THEN
1767c IGRV(2,I)=ND+10*(J+1)
1768c GO TO 890
1769c ENDIF
1770c 895 CONTINUE
1771c CALL ANSTCKC(7,'GRAVITY')
1772c CALL ANSTCKI(NOSKEW)
1773c CALL ANCERR(137,ANINFO_BLIND_1)
1774c 890 CONTINUE
1775C
1776C=======================================================================
1777C
1778C (III) SENSOR NUMBERING
1779C
1780C=======================================================================
1781C CONVECTIVE HEAT FLUX
1782C-------------------------
1783 DO i=1,glob_therm%NUMCONV
1784 isens = ibcv(6,i)
1785 IF(isens/=0) THEN
1786 DO j=1,sensors%NSENSOR
1787 IF(isens == sensors%SENSOR_TAB(j)%SENS_ID) THEN
1788 ibcv(6,i) = j
1789 GO TO 801
1790 ENDIF
1791 ENDDO
1792 CALL ancmsg(msgid=1605,msgtype=msgerror,anmode=aninfo_blind_1,
1793 . c1='CONVECTIVE HEAT FLUX',i1=isens)
1794 ENDIF
1795 801 CONTINUE
1796 ENDDO
1797C------------------------
1798C RADIATIVE HEAT FLUX
1799C------------------------
1800 DO i=1,glob_therm%NUMRADIA
1801 isens = ibcr(6,i)
1802 IF(isens/=0) THEN
1803 DO j=1,sensors%NSENSOR
1804 IF(isens == sensors%SENSOR_TAB(j)%SENS_ID) THEN
1805 ibcr(6,i) = j
1806 GO TO 802
1807 ENDIF
1808 ENDDO
1809 CALL ancmsg(msgid=1605,msgtype=msgerror,anmode=aninfo_blind_1,
1810 . c1='RADIATIVE HEAT FLUX',i1=isens)
1811 ENDIF
1812 802 CONTINUE
1813 ENDDO
1814C---------------------
1815C IMPOSED HEAT FLUX
1816C---------------------
1817 DO i=1,glob_therm%NFXFLUX
1818 isens = ibfflux(6,i)
1819 IF(isens/=0) THEN
1820 DO j=1,sensors%NSENSOR
1821 IF(isens == sensors%SENSOR_TAB(j)%SENS_ID) THEN
1822 ibfflux(6,i) = j
1823 GO TO 803
1824 ENDIF
1825 ENDDO
1826 CALL ancmsg(msgid=1605,msgtype=msgerror,anmode=aninfo_blind_1,
1827 . c1='IMPOSED HEAT FLUX',i1=isens)
1828 ENDIF
1829 803 CONTINUE
1830 ENDDO
1831
1832C---------------------
1833C IMPOSED TEMPERATURE
1834C---------------------
1835 DO i=1,glob_therm%NFXTEMP
1836 isens = ibft(3,i)
1837 IF (isens > 0) THEN
1838 DO j=1,sensors%NSENSOR
1839 IF (isens == sensors%SENSOR_TAB(j)%SENS_ID) THEN
1840 ibft(3,i) = j
1841 EXIT
1842 ENDIF
1843 ENDDO
1844 END IF
1845 ENDDO
1846
1847C---------------------
1848C IMPOSED DISPLACEMENTS/VELOCITIES/ACCELERATIONS
1849C---------------------
1850 DO i=1,nfxvel
1851 isens = ibfvel(4,i)
1852 IF (isens > 0) THEN
1853 DO j=1,sensors%NSENSOR
1854 IF (isens == sensors%SENSOR_TAB(j)%SENS_ID) THEN
1855 ibfvel(4,i) = j
1856 EXIT
1857 ENDIF
1858 ENDDO
1859 END IF
1860 ENDDO
1861c
1862C----------------------------
1863C (IV) TRAITEMENT DES TABLES
1864C----------------------------
1865C
1866C 1) LOIS 73
1867C
1868 DO i=1,nummat
1869C
1870 ilaw=nint(pm(19,i))
1871C
1872 id=ipm(1,i)
1873 CALL fretitl2(titr,ipm(npropmi-ltitr+1,i),ltitr)
1874 IF(ilaw == 73) THEN
1875 itable=ipm(227,i)
1876 IF(itable/=0)THEN
1877 DO j=1,ntable
1878 IF(itable == table(j)%NOTABLE) THEN
1879 ipm(227,i)=j
1880 GOTO 900
1881 ENDIF
1882 END DO
1883 CALL ancmsg(msgid=779,
1884 . msgtype=msgerror,
1885 . anmode=aninfo,
1886 . i1=id,
1887 . c1=titr,
1888 . i2=itable)
1889 ENDIF
1890 900 CONTINUE
1891 itable=ipm(227,i)
1892 IF(table(itable)%NDIM/=3)THEN
1893 CALL ancmsg(msgid=780,
1894 . msgtype=msgerror,
1895 . anmode=aninfo_blind_1,
1896 . i1=id,
1897 . c1=titr,
1898 . i2=itable)
1899 END IF
1900c -- young evolution
1901 IF (nf > 0) THEN
1902 ife=ipm(10+nf,i)
1903 IF (ife /= 0)THEN
1904 ie =npc(ife)
1905 ie2=npc(ife+1)
1906 DO ii = ie+1,ie2-3,2
1907 IF(pld(ii) < pld(ii+2))THEN
1908 CALL ancmsg(msgid=975,
1909 . msgtype=msgerror,
1910 . anmode=aninfo,
1911 . i1=id,
1912 . c1=titr)
1913 EXIT
1914 ENDIF
1915 ENDDO
1916 ENDIF
1917 ENDIF
1918
1919 ELSEIF(ilaw == 74)THEN
1920 itable=ipm(227,i)
1921 IF(itable/=0)THEN
1922 DO j=1,ntable
1923 IF(itable == table(j)%NOTABLE) THEN
1924 ipm(227,i)=j
1925 GOTO 901
1926 ENDIF
1927 END DO
1928 CALL ancmsg(msgid=779,
1929 . msgtype=msgerror,
1930 . anmode=aninfo,
1931 . i1=id,
1932 . c1=titr,
1933 . i2=itable)
1934 ENDIF
1935 901 CONTINUE
1936 itable=ipm(227,i)
1937 IF(table(itable)%NDIM/=2.AND.table(itable)%NDIM/=3)THEN
1938 CALL ancmsg(msgid=823,
1939 . msgtype=msgerror,
1940 . anmode=aninfo_blind_1,
1941 . i1=id,
1942 . c1=titr,
1943 . i2=itable)
1944 END IF
1945c -- young evolution
1946 IF (nf > 0) THEN
1947 ife=ipm(10+nf,i)
1948 IF(ife /= 0)THEN
1949 ie =npc(ife)
1950 ie2=npc(ife+1)
1951 DO ii = ie+1,ie2-3,2
1952 IF(pld(ii) < pld(ii+2))THEN
1953 CALL ancmsg(msgid=975,
1954 . msgtype=msgerror,
1955 . anmode=aninfo,
1956 . i1=id,
1957 . c1=titr)
1958 EXIT
1959 ENDIF
1960 ENDDO
1961 ENDIF
1962 ENDIF
1963
1964
1965 ELSEIF(ilaw == 80)THEN
1966 DO 980 k = 1,ipm(226,i)!NTABLE
1967 itable= ipm(226+k,i)
1968 iadd = ipm(7,i) - 1
1969 IF(itable/=0)THEN
1970 DO j=1,ntable
1971 IF(itable == table(j)%NOTABLE) THEN
1972 ipm(226+k,i)=j
1973 itable=ipm(226+k,i)
1974 IF(table(itable)%NDIM >= 2 )THEN
1975 bufmat(iadd+15) = zero
1976 ENDIF
1977 IF(table(itable)%NDIM > 3 )THEN
1978 CALL ancmsg(msgid=1030,
1979 . msgtype=msgerror,
1980 . anmode=aninfo_blind_1,
1981 . i1=id,
1982 . c1=titr,
1983 . i2=itable)
1984 EXIT
1985 END IF
1986 GOTO 980
1987 ENDIF
1988 END DO
1989 CALL ancmsg(msgid=779,
1990 . msgtype=msgerror,
1991 . anmode=aninfo,
1992 . i1=id,
1993 . c1=titr,
1994 . i2=itable)
1995 ENDIF
1996 980 CONTINUE
1997c -- young evolution
1998 IF (nf > 0) THEN
1999 ife=ipm(10+nf,i)
2000 IF(ife /= 0)THEN
2001 ie =npc(ife)
2002 ie2=npc(ife+1)
2003 DO ii = ie+1,ie2-3,2
2004 IF(pld(ii) < pld(ii+2))THEN
2005 CALL ancmsg(msgid=975,
2006 . msgtype=msgerror,
2007 . anmode=aninfo,
2008 . i1=id,
2009 . c1=titr)
2010 EXIT
2011 ENDIF
2012 ENDDO
2013 ENDIF
2014 ENDIF
2015
2016 ENDIF
2017 END DO
2018C----------------------
2019C USER
2020C----------------------
2021 CALL iniguser(bufgeo,igeo,ipm,npc1)
2022C------------------------------------------------------------------
2023C POINTS DE DETONATION,
2024C SEGMENTS DE DETONATION,
2025C DETONATION AVEC ECRAN,
2026C PLANAR DETONATION WAVE.
2027C------------------------------------------------------------------
2028C Traitement des id matriau (Mdet) dans lecdet.F avec le check des user flags
2029
2030 RETURN
2031C-----
2032 END
2033C
2034!||====================================================================
2035!|| m20dcod ../starter/source/system/fsdcod.F
2036!||--- called by ------------------------------------------------------
2037!|| lectur ../starter/source/starter/lectur.F
2038!||--- calls -----------------------------------------------------
2039!|| ancmsg ../starter/source/output/message/message.F
2040!|| arret ../starter/source/system/arret.F
2041!|| fretitl2 ../starter/source/starter/freform.F
2042!||--- uses -----------------------------------------------------
2043!|| elbuftag_mod ../starter/share/modules1/elbuftag_mod.F
2044!|| message_mod ../starter/share/message_module/message_mod.F
2045!||====================================================================
2046 SUBROUTINE m20dcod(MLAW_TAG, IPM ,PM, MAT_PARAM)
2047C-----------------------------------------------
2048C M o d u l e s
2049C-----------------------------------------------
2050 USE message_mod
2051 USE matparam_def_mod, ONLY : matparam_struct_
2052 USE elbufdef_mod
2053 USE elbuftag_mod
2054 USE names_and_titles_mod , ONLY : nchartitle
2055C-----------------------------------------------
2056C I m p l i c i t T y p e s
2057C-----------------------------------------------
2058#include "implicit_f.inc"
2059C-----------------------------------------------
2060C C o m m o n B l o c k s
2061C-----------------------------------------------
2062#include "com04_c.inc"
2063#include "param_c.inc"
2064#include "scr17_c.inc"
2065C-----------------------------------------------
2066C D u m m y A r g u m e n t s
2067C-----------------------------------------------
2068 TYPE(mlaw_tag_), TARGET, DIMENSION(NUMMAT) :: MLAW_TAG
2069 INTEGER IPM(NPROPMI,NUMMAT)
2070 my_real PM(NPROPM,NUMMAT)
2071 TYPE(MATPARAM_STRUCT_) ,DIMENSION(NUMMAT) ,INTENT(INOUT) :: MAT_PARAM
2072C-----------------------------------------------
2073C L o c a l V a r i a b l e s
2074C-----------------------------------------------
2075 INTEGER I, ILAW, J, K, IS, NF,ILAWk
2076 my_real pun,rho_max
2077 INTEGER ID
2078 CHARACTER(LEN=NCHARTITLE) :: TITR
2079 LOGICAL PASSED
2080 TYPE(MLAW_TAG_), POINTER :: MTAG, MTAGk
2081C-----------------------------------------------
2082 DATA pun/0.1/
2083C-----------------------------------------------
2084C SUBMAT FOR MULTIUMAT LAW20
2085C-----------------------------------------------
2086C
2087 DO i=1,nummat
2088 ilaw=nint(pm(19,i))
2089 IF(ilaw == 20) THEN
2090 id=ipm(1,i)
2091 CALL fretitl2(titr,ipm(npropmi-ltitr+1,i),ltitr)
2092 nf=nint(pm(40,i))
2093 rho_max=zero
2094 j = 1
2095 DO k=1,2
2096 passed=.true.
2097 is=mat_param(i)%MULTIMAT%MID(k)
2098 IF(is/=0) THEN
2099 DO j=1,nummat
2100 IF(is == ipm(1,j)) THEN
2101 mat_param(i)%MULTIMAT%MID(k)=j
2102 rho_max=max(rho_max,pm(1,j))
2103 GOTO 200
2104 ENDIF
2105 ENDDO
2106 passed=.false.
2107 ENDIF
2108 CALL ancmsg(msgid=128,msgtype=msgerror,anmode=aninfo_blind_1,i1=id,c1=titr,i2=is)
2109 CALL arret(2)
2110 200 CONTINUE !found
2111 !LAW20 material buffer is dimensioned from submaterial buffer dimensions.
2112 IF(passed)THEN
2113 ilawk = ipm(2,j)
2114 mtag => mlaw_tag(i)
2115 mtagk => mlaw_tag(j)
2116 mtag%L_BFRAC= max(mtag%L_BFRAC, mtagk%L_BFRAC)
2117 mtag%L_TEMP = max(mtag%L_TEMP , mtagk%L_TEMP )
2118 mtag%L_PLA = max(mtag%L_PLA , mtagk%L_PLA )
2119 mtag%G_BFRAC= max(mtag%G_BFRAC, mtagk%G_BFRAC)
2120 mtag%G_TEMP = max(mtag%G_TEMP , mtagk%G_TEMP )
2121 mtag%G_PLA = max(mtag%G_PLA , mtagk%G_PLA )
2122 ENDIF
2123 ENDDO !next K
2124 pm(91,i)=rho_max
2125
2126 ELSE IF (ilaw == 151) THEN
2127 id=ipm(1,i)
2128 CALL fretitl2(titr,ipm(npropmi-ltitr+1,i),ltitr)
2129 nf = mat_param(i)%MULTIMAT%NB ! Number of submaterials
2130 rho_max=zero
2131 DO k = 1, nf
2132 is = mat_param(i)%MULTIMAT%MID(k)
2133 DO j = 1, nummat
2134 IF (is == ipm(1, j)) THEN
2135 ipm(20 + k, i) = j
2136 mat_param(i)%MULTIMAT%MID(k) = j
2137 ilawk = ipm(2,j)
2138 mtag => mlaw_tag(i)
2139 mtagk => mlaw_tag(j)
2140 mtag%L_BFRAC= max(mtag%L_BFRAC, mtagk%L_BFRAC)
2141 mtag%L_TB= max(mtag%L_BFRAC, mtagk%L_TB)
2142 mtag%L_TEMP = max(mtag%L_TEMP , mtagk%L_TEMP )
2143 mtag%L_PLA = max(mtag%L_PLA , mtagk%L_PLA )
2144 mtag%G_BFRAC= max(mtag%G_BFRAC, mtagk%G_BFRAC)
2145 mtag%G_TB= max(mtag%G_TB, mtagk%G_TB)
2146 mtag%G_TEMP = max(mtag%G_TEMP , mtagk%G_TEMP )
2147 mtag%G_PLA = max(mtag%G_PLA , mtagk%G_PLA )
2148 rho_max=max(rho_max,pm(1,j))
2149 ENDIF
2150 enddo!next J
2151 pm(91,i)=rho_max
2152 ENDDO
2153 ENDIF
2154 ENDDO !next I=1,NUMMAT
2155
2156 RETURN
2157 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:2047
iniguser
subroutine iniguser(bufgeo, igeo, ipm, npc)
Definition iniguser.F:35
max
#define max(a, b)
Definition macros.h:21
elbuftag_mod
Definition elbuftag_mod.F:227
intstamp_mod
Definition intstamp_mod.F:38
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
table_mod
Definition table_mod.F:112
nintri
integer function nintri(iext, antn, m, n, m1)
Definition nintrr.F:46
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
fretitl2
subroutine fretitl2(titr, iasc, l)
Definition freform.F:804
arret
subroutine arret(nn)
Definition arret.F:87
starter
program starter
Definition starter.F:39
elbuftag_mod::mlaw_tag_
Definition elbuftag_mod.F:232