Télécharger chame1.eso

Retour à la liste

Numérotation des lignes :

chame1
  1. C CHAME1 SOURCE OF166741 23/12/04 21:15:05 11800
  2. SUBROUTINE CHAME1(IPMAIL,IPMODL,IPCHPO,CHA,IPCHEL,ISUP)
  3. C____________________________________________________________________*
  4. C *
  5. C transformation de CHPOINT en MCHAML *
  6. C *
  7. C entrees: *
  8. C ________ *
  9. C *
  10. C ipmail pointeur sur un maillage *
  11. C ou ipmodl pointeur sur un mmodel *
  12. C ipchpo pointeur sur le chpoint *
  13. C cha chaine de caractere contenant un sous type eventuel
  14. C isup indique le type de support demande : *
  15. C 1 le mchaml est laisse aux noeuds *
  16. C 2 au centre de gravite *
  17. C 3 aux points de gauss de la raideur *
  18. C 4 aux points de gauss de la masse *
  19. C 5 aux points de gauss des contraintes *
  20. C 6 aux point de gauss de la thermique & diffusion *
  21. C & metallurgie *
  22. C *
  23. C sorties: *
  24. C ________ *
  25. C *
  26. C ipchel pointeur sur le mchaml resultat *
  27. C *
  28. C Remarque : le passage du mchaml sur un autre support que les *
  29. C -------- noeuds n'est possible que si l'on a donne un mmodel *
  30. C *
  31. C le traitement d'harmoniques de fourier n'est pas *
  32. C implemente *
  33. C *
  34. C____________________________________________________________________*
  35. C *
  36. IMPLICIT INTEGER(I-N)
  37. IMPLICIT REAL*8(A-H,O-Z)
  38.  
  39.  
  40. -INC PPARAM
  41. -INC CCOPTIO
  42. -INC CCGEOME
  43. -INC CCASSIS
  44. -INC CCPRECO
  45.  
  46. -INC SMCHAML
  47. -INC SMCHPOI
  48. -INC SMINTE
  49. -INC SMMODEL
  50. -INC SMELEME
  51. -INC SMCOORD
  52.  
  53. COMMON/cham1c/IPARA1,IPARA2
  54. EXTERNAL CHAM1I
  55. LOGICAL BTHRD
  56.  
  57. SEGMENT SPARA1
  58. INTEGER NBTHR1
  59. INTEGER IPCH1
  60. INTEGER IPTP1
  61. INTEGER IPTR1
  62. ENDSEGMENT
  63.  
  64. SEGMENT SPARA2
  65. INTEGER NBTHRD
  66. INTEGER IISUP
  67. INTEGER IPSAU
  68. INTEGER IPMOD
  69. INTEGER IPCHE
  70. INTEGER IPTPR
  71. INTEGER IPTRA
  72. ENDSEGMENT
  73.  
  74. SEGMENT INFO
  75. INTEGER INFELL(JG)
  76. ENDSEGMENT
  77.  
  78. SEGMENT ISAUT(IVAL,NSOUS)
  79. SEGMENT ICPR(nbpts)
  80.  
  81. SEGMENT MTRA2
  82. C Copie du CHPOINT dans MTRA2 pour aller plus vite ensuite
  83. CHARACTER*(LOCOMP) INCO(N2)
  84. REAL*8 BB(NX,N2)
  85. C INCO : Nom des INCONNUES du CHPOINT
  86. C BB : Valeurs au noeuds du MMODEL (associees au ICPR)
  87. C NX : Nombre de noeuds differents dans le MODELE
  88. C N2 : Nombre de composantes dans le CHPOINT
  89. ENDSEGMENT
  90.  
  91. CHARACTER*(*) CHA
  92. CHARACTER*(LOCOMP) MOCOMP
  93. CHARACTER*1 MO1,VID1
  94.  
  95. C soutyp = sous-type du champ par element resultat
  96. C lsouty = longueur utile de la chaine "soutyp"
  97. C
  98. INTEGER LSOUTY
  99. CHARACTER*72 SOUTYP
  100. C
  101. LOGICAL ICOQ
  102. C
  103. * write(6,*) 'chame1 ',ipmAIL,IPMODL,IPCHPO,CHA,ISUP
  104. * preconditionnement on regarde si on a sauve le resultat
  105. * on ne fait l'horodatage que pour le chp par mesure d'economie
  106. ith=oothrd
  107. call oooho1(ipmail,ihomai)
  108. call oooho1(ipmodl,ihomod)
  109. call oooho1(ipchpo,ihochp)
  110. do 100 iprec=1,nprcha
  111. if (iprma(iprec,ith).ne.ipmail) goto 100
  112. if (iprhoa(iprec,ith).ne.ihomai) goto 100
  113. if (iprmo(iprec,ith).ne.ipmodl) goto 100
  114. if (iprhom(iprec,ith).ne.ihomod) goto 100
  115. if (iprchp(iprec,ith).ne.ipchpo) goto 100
  116. if (iprhoc(iprec,ith).ne.ihochp) goto 100
  117. if (iprsu(iprec,ith).ne.isup ) goto 100
  118. if (iprcha(iprec,ith).ne.cha ) goto 100
  119. * preconditionnement trouve
  120. ipchel=iprchl(iprec,ith)
  121. ** if(ith.eq.1)
  122. ** > write(6,*) ' preconditionnement trouve ',iprec,ith,ipchel
  123. call actobj('MCHAML',ipchel,1)
  124. return
  125. 100 continue
  126.  
  127. IPARA1= 0
  128. IPARA2= 0
  129.  
  130. NT1 = 1
  131. NT2 = 1
  132. IOPTIM= 100
  133.  
  134. INFO = 0
  135. ISUP1 = ISUP
  136. IPCHEL= 0
  137. NPINT = 0
  138. VID1 =' '
  139.  
  140. ither = 0
  141. idiff = 0
  142. imeta = 0
  143. C
  144. C on cree l'objet maillage contenant tous les points du chpoint
  145. C
  146. MCHPOI=IPCHPO
  147. NSOUPO=IPCHP(/1)
  148. C
  149. IF (IPMAIL.NE.0) THEN
  150. IPT1=IPMAIL
  151. NSOUS=IPT1.LISOUS(/1)
  152. IF (NSOUS.EQ.0) THEN
  153. NSOUS=1
  154. ENDIF
  155. ISUP1=1
  156. ELSE IF (IPMODL.NE.0) THEN
  157. MMODEL = IPMODL
  158. NSOUS = KMODEL(/1)
  159. ENDIF
  160. C
  161. C initialisation du segment descripteur du champ par element
  162. C
  163. N1=NSOUS
  164. N3=6
  165. MO1 = CHA(1:1)
  166. IF (MO1.EQ.VID1) THEN
  167. L1=8
  168. SOUTYP=MTYPOI
  169. ELSE
  170. L1=LEN(CHA)
  171. SOUTYP=CHA
  172. ENDIF
  173.  
  174. C Renvoi le nombre de composantes
  175. CALL NBCOMP(MCHPOI,'CHPOINT ',N2)
  176.  
  177. NX =0
  178. N2PTEL=0
  179. N2EL =0
  180. ISOUSs=0
  181.  
  182. C Dimensionnement de ISAUT
  183. IF(IPMODL .NE. 0)THEN
  184. IVAL=6
  185. ELSE
  186. IVAL=3
  187. ENDIF
  188. C
  189. ICOQ=.FALSE.
  190. DO ISOUPO=1,NSOUPO
  191. MSOUPO=IPCHP(ISOUPO)
  192. NCOMPO=NOCOMP(/2)
  193. DO ICO=1,NCOMPO
  194. MOCOMP=MSOUPO.NOCOMP(ICO)
  195. IF (MOCOMP(1:4).EQ.'TINF'.OR.MOCOMP(1:4).EQ.'TSUP') THEN
  196. ICOQ=.TRUE.
  197. IVAL = IVAL + 2
  198. GOTO 1
  199. ENDIF
  200. ENDDO
  201. ENDDO
  202. 1 CONTINUE
  203.  
  204. IF(OOTHRD .NE.0) call oooprl(1)
  205. SEGINI,ICPR,ISAUT
  206. IF(OOTHRD .NE.0) call oooprl(0)
  207.  
  208. DO 19 ISOUS=1,NSOUS
  209. ISUP1 =ISUP
  210. IPMINT=0
  211. IF (IPMAIL.NE.0) THEN
  212. IF (NSOUS.GT.1) THEN
  213. IPT2=IPT1.LISOUS(ISOUS)
  214. ELSE
  215. IPT2=IPMAIL
  216. ENDIF
  217.  
  218. ELSEIF (IPMODL.NE.0) THEN
  219. IMODEL = KMODEL(ISOUS)
  220. c pour les elements MULT, on autorise que les MCHAML aux noeuds
  221. if(ISUP1.ne.1) then
  222. itest=nefmod
  223. if(itest.eq.22.OR.itest.eq.259) goto 19
  224. endif
  225. IPT2 = IMAMOD
  226.  
  227. if (formod(1)(1:8).eq.'LIAISON ') then
  228. C ne fait rien si le maillage de LIAISON n'appartient pas au CHPOINT
  229.  
  230. IVAL1 = IPT2.num(1,1)
  231. DO I=1,NSOUPO
  232. MSOUPO=IPCHP(I)
  233. MELEME=IGEOC
  234. do jno = 1, num(/2)
  235. if (num(1,jno).eq.IVAL1) goto 191
  236. enddo
  237. goto 19
  238. ENDDO
  239. endif
  240. 191 CONTINUE
  241.  
  242. IMODEL = KMODEL(ISOUS)
  243. IF(INFMOD(/1).NE.0) NPINT=INFMOD(1)
  244. C
  245. C Changement de support si besoin selon la formulation ?
  246. IF (ISUP1 .NE. 1) THEN
  247. NFOR = FORMOD(/2)
  248. CALL PLACE(FORMOD,NFOR,icont,'CONTACT ')
  249. CALL PLACE(FORMOD,NFOR,ichph,'CHANGEMENT_PHASE')
  250. IF (icont.NE.0 .OR. ichph.NE.0) THEN
  251. ISUP1 = 1
  252. ELSE
  253. CALL PLACE(FORMOD,NFOR,ither,'THERMIQUE')
  254. CALL PLACE(FORMOD,NFOR,idiff,'DIFFUSION')
  255. CALL PLACE(FORMOD,NFOR,imeta,'METALLURGIE')
  256. IF (ither.NE.0 .OR. idiff.NE.0 .OR. imeta.NE.0) THEN
  257. nmat = matmod(/2)
  258. CALL PLACE(matmod,nmat,iray,'RAYONNEMENT')
  259. C Support 6 SAUF pour le RAYONNEMENT...
  260. C Les cas-tests de RAYONNEMENT sont en erreur sans ca...
  261. IF (iray.EQ.0) THEN
  262. IF (ISUP1.GT.2) ISUP1 = 6
  263. ENDIF
  264. ENDIF
  265. ENDIF
  266. ENDIF
  267. C
  268. C on recupere le pointeur sur le minte correspondant a isup1
  269. C
  270. IF (ISUP1.GT.1) THEN
  271. MELE=NEFMOD
  272. C cas de la THERMIQUE(sauf RAYONNEMENT) OU DIFFUSION OU METALLURGIE
  273. IF (ither.NE.0 .OR. idiff.NE.0 .OR. imeta.NE.0) THEN
  274. IF ( ISUP1 .EQ. 2) THEN
  275. CALL TSHAPE(MELE,'GRAVITE',IPMINT)
  276. cc ELSE IF ( ISUP1 .EQ. 6) THEN
  277. ELSE
  278. CALL TSHAPE(MELE,'GAUSS ',IPMINT)
  279. ENDIF
  280. IF (IERR.NE.0) RETURN
  281. IELE = NUMGEO(MELE)
  282. NBNN = NBNNE(IELE)
  283. ELSE
  284. if(2+isup1.gt.infmod(/1)) then
  285. CALL ELQUOI(MELE,0,ISUP1,INFO,IMODEL)
  286. IF (IERR.NE.0) RETURN
  287. IPMINT=INFELL(11)
  288. else
  289. IPMINT=infmod(2+isup1)
  290. IELE =INFELE(14)
  291. NBNN =NBNNE(IELE)
  292. endif
  293. ENDIF
  294. C
  295. C initialisation de ipore pour milieu poreux
  296. C
  297. IPORE=0
  298. IF(MELE.GE.79 .AND.MELE.LE.83 ) IPORE=NBNN
  299. IF(MELE.GE.173.AND.MELE.LE.177) IPORE=NBNN
  300. IF(MELE.GE.178.AND.MELE.LE.182) IPORE=NBNN
  301. C cas XFEM il faut seulement les 4 premier noeuds (support geometrique)
  302. IF(MELE.GE.263) IPORE=NBNN
  303.  
  304. ISAUT(4,ISOUS)=IPMINT
  305. IF(IPORE .EQ. 0)THEN
  306. MINTE =IPMINT
  307. ISAUT(5,ISOUS)=SHPTOT(/2)
  308. ELSE
  309. ISAUT(5,ISOUS)=IPORE
  310. ENDIF
  311. ENDIF
  312.  
  313. ISAUT(6,ISOUS)= ISUP1
  314. C
  315. C Quels sont les modeles concernes par TINF et TSUP
  316. IF (ICOQ) THEN
  317. ISAUT(IVAL-1,ISOUS)=0
  318. IPNOMC = 0
  319. CALL PLACE(FORMOD,NFOR,ITHER,'THERMIQUE')
  320. IF (ITHER.NE.0) THEN
  321. IPNOMC = LNOMID(1)
  322. ENDIF
  323. CALL PLACE(FORMOD,NFOR,IMECA,'MECANIQUE')
  324. IF (IMECA.NE.0) THEN
  325. IPNOMC = LNOMID(8)
  326. ENDIF
  327. IF (IPNOMC.EQ.0) GOTO 192
  328. NOMID = IPNOMC
  329. NCOBL = LESOBL(/2)
  330. DO IJC = 1,NCOBL
  331. MOCOMP = LESOBL(IJC)
  332. IF (MOCOMP(1:4).EQ.'TINF'.OR.MOCOMP(1:4).EQ.'TSUP') THEN
  333. ISAUT(IVAL-1,ISOUS)=1
  334. GOTO 192
  335. ENDIF
  336. ENDDO
  337. 192 CONTINUE
  338. ENDIF
  339. C
  340. ELSE
  341. CALL ERREUR(5)
  342. RETURN
  343. ENDIF
  344.  
  345. ISOUSs=ISOUSs+1
  346.  
  347. ISAUT(1,ISOUS) = IPT2
  348.  
  349. NBNO = IPT2.NUM(/1)
  350. N1EL = IPT2.NUM(/2)
  351.  
  352. C Remplissage de l'ICPR a partir des noeuds du MMODEL
  353. C L'utilisation d'un ICPR par MMODEL limite l'utilisation de
  354. C memoire en parallele des les ASSISTANTS
  355. DO IEL=1,N1EL
  356. DO INO=1,NBNO
  357. INOEU=IPT2.NUM(INO,IEL)
  358. IF(ICPR(INOEU) .EQ. 0)THEN
  359. NX=NX+1
  360. ICPR(INOEU)=NX
  361. ENDIF
  362. ENDDO
  363. ENDDO
  364.  
  365. IF(IPMINT .EQ. 0)THEN
  366. N1PTEL=NBNO
  367. ELSE
  368. MINTE =IPMINT
  369. N1PTEL=SHPTOT(/3)
  370. ENDIF
  371.  
  372. ISAUT(2,ISOUSs) = N1EL
  373. ISAUT(3,ISOUSs) = N1PTEL
  374.  
  375. NT2 = MAX(NT2,N1EL*N1PTEL)
  376. 19 CONTINUE
  377.  
  378. C Creation d'un MAXIMUM de SEGMENTS dans un LOCK
  379. N1=ISOUSs
  380. IF(OOTHRD .NE.0) call oooprl(1)
  381. SEGINI,MCHELM
  382. DO ISOUSs=1,N1
  383. SEGINI,MCHAML
  384. ICHAML(ISOUSs)=MCHAML
  385. N1EL =ISAUT(2,ISOUSs)
  386. N1PTEL=ISAUT(3,ISOUSs)
  387. DO ICOMP=1,N2
  388. SEGINI,MELVAL
  389. IELVAL(ICOMP)=MELVAL
  390. ENDDO
  391. IF (ISAUT(IVAL-1,ISOUSs).EQ.1) THEN
  392. SEGINI,MELVAL
  393. ISAUT(IVAL,ISOUSs)=MELVAL
  394. ENDIF
  395. ENDDO
  396. SEGINI,MTRA2
  397. IF(OOTHRD .NE.0) call oooprl(0)
  398.  
  399. TITCHE=SOUTYP
  400. IFOCHE=IFOUR
  401.  
  402. NCO = 0
  403. DO ISOUPO=1,NSOUPO
  404. MSOUPO=IPCHP(ISOUPO)
  405. MELEME=IGEOC
  406. NT1 =MAX(NT1,NUM(/2))
  407. NC =MSOUPO.NOHARM(/1)
  408. DO 101 ICO=1,NC
  409. MOCOMP=MSOUPO.NOCOMP(ICO)
  410. DO K=1,NCO
  411. IF(MOCOMP .EQ. MTRA2.INCO(K))GOTO 101
  412. ENDDO
  413. NCO = NCO + 1
  414. K = NCO
  415. MTRA2.INCO(NCO)=MOCOMP
  416. 101 CONTINUE
  417. ENDDO
  418.  
  419. C----------------------------------------------------------------------C
  420. C Remplissage du MTRA2
  421. C----------------------------------------------------------------------C
  422. NBTHR=MIN(MAX(NT1/IOPTIM,1),NBTHRS)
  423. IF ((NBTHR .EQ. 1) .OR. (NBTHRS .EQ. 1) .OR. (OOTHRD .GT. 0)) THEN
  424. C CB215821 : DESACTIVE LA PARALLELISATION PTHREAD LORSQUE ON EST
  425. C DEJA DANS LES ASSISTANTS
  426. NBTHR = 1
  427. BTHRD = .FALSE.
  428. ELSE
  429. BTHRD = .TRUE.
  430. CALL THREADII
  431. ENDIF
  432.  
  433. IF (BTHRD) THEN
  434. C Remplissage du 'COMMON/cham1c'
  435. SEGINI,SPARA1
  436. IPARA1=SPARA1
  437. IPARA2=0
  438.  
  439. SPARA1.NBTHR1=NBTHR
  440. SPARA1.IPCH1 =MCHPOI
  441. SPARA1.IPTP1 =ICPR
  442. SPARA1.IPTR1 =MTRA2
  443.  
  444. DO ith=2,NBTHR
  445. CALL THREADID(ith,CHAM1i)
  446. ENDDO
  447. CALL CHAM1i(1)
  448.  
  449. C Attente de la fin de tous les threads en cours de travail
  450. DO ith=2,NBTHR
  451. CALL THREADIF(ith)
  452. ENDDO
  453.  
  454. C On libère les Threads
  455. CALL THREADIS
  456. SEGSUP,SPARA1
  457.  
  458. ELSE
  459. C Appel de la SUBROUTINE qui fait le travail
  460. ith=1
  461. CALL CHAM11(NBTHR,ith,MCHPOI,ICPR,MTRA2)
  462. ENDIF
  463.  
  464. C----------------------------------------------------------------------C
  465. C Remplissage du MCHAML
  466. C----------------------------------------------------------------------C
  467.  
  468.  
  469. NBTHR=MIN(MAX(NT2/IOPTIM,1),NBTHRS)
  470. IF ((NBTHR .EQ. 1) .OR. (NBTHRS .EQ. 1) .OR. (OOTHRD .GT. 0)) THEN
  471. C CB215821 : DESACTIVE LA PARALLELISATION PTHREAD LORSQUE ON EST
  472. C DEJA DANS LES ASSISTANTS
  473. NBTHR = 1
  474. BTHRD = .FALSE.
  475. ELSE
  476. BTHRD = .TRUE.
  477. CALL THREADII
  478. ENDIF
  479.  
  480. IF (BTHRD) THEN
  481. C Remplissage du 'COMMON/cham1c'
  482. SEGINI,SPARA2
  483. IPARA1=0
  484. IPARA2=SPARA2
  485.  
  486. SPARA2.NBTHRD=NBTHR
  487. SPARA2.IISUP =ISUP
  488. SPARA2.IPSAU =ISAUT
  489. SPARA2.IPMOD =IPMODL
  490. SPARA2.IPCHE =MCHELM
  491. SPARA2.IPTPR =ICPR
  492. SPARA2.IPTRA =MTRA2
  493.  
  494. DO ith=2,NBTHR
  495. CALL THREADID(ith,CHAM1i)
  496. ENDDO
  497. CALL CHAM1i(1)
  498.  
  499. C Attente de la fin de tous les threads en cours de travail
  500. DO ith=2,NBTHR
  501. CALL THREADIF(ith)
  502. ENDDO
  503.  
  504. C On libere les Threads
  505. CALL THREADIS
  506. SEGSUP,SPARA2
  507.  
  508. ELSE
  509. C Appel de la SUBROUTINE qui fait le travail
  510. ith=1
  511. CALL CHAM12(NBTHR,ith,ISUP,ISAUT,IPMODL,MCHELM,ICPR,MTRA2)
  512. ENDIF
  513. C
  514. C Modification pour les modeles avec TINF ou TSUP
  515. IF (ICOQ.AND.IPMODL.NE.0) THEN
  516. DO IJM = 1,NSOUS
  517. IF (ISAUT(IVAL-1,IJM).EQ.2) THEN
  518. MCHAM1=ICHAML(IJM)
  519. DO IJC = 1,N2
  520. MOCOMP=MCHAM1.NOMCHE(IJC)
  521. IF (MOCOMP.EQ.'T ') GOTO 25
  522. ENDDO
  523. 25 CONTINUE
  524. MCHAM1.IELVAL(IJC)=ISAUT(IVAL,IJM)
  525. ENDIF
  526. ENDDO
  527. ENDIF
  528. C
  529. SEGSUP,MTRA2,ISAUT,ICPR
  530. IF(INFO .NE. 0)SEGSUP,INFO
  531.  
  532. IPCHEL=MCHELM
  533. * preconditionnement on garde l'operation en memoire
  534. ith=oothrd
  535. do iprec=nprcha,2,-1
  536. iprma(iprec,ith) =iprma(iprec-1,ith)
  537. iprhoa(iprec,ith)=iprhoa(iprec-1,ith)
  538. iprmo(iprec,ith) =iprmo(iprec-1,ith)
  539. iprhom(iprec,ith)=iprhom(iprec-1,ith)
  540. iprchp(iprec,ith)=iprchp(iprec-1,ith)
  541. iprhoc(iprec,ith)=iprhoc(iprec-1,ith)
  542. iprsu(iprec,ith) =iprsu(iprec-1,ith)
  543. iprcha(iprec,ith)=iprcha(iprec-1,ith)
  544. iprchl(iprec,ith)=iprchl(iprec-1,ith)
  545. enddo
  546. iprma(1,ith) =ipmail
  547. iprhoa(1,ith)=ihomai
  548. iprmo(1,ith) =ipmodl
  549. iprhom(1,ith)=ihomod
  550. iprchp(1,ith)=ipchpo
  551. iprhoc(1,ith)=ihochp
  552. iprsu(1,ith) =isup
  553. iprcha(1,ith)=cha
  554. iprchl(1,ith)=ipchel
  555. ** write(6,*) ' preconditionnement de ',ipchel
  556.  
  557. END
  558.  
  559.  
  560.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales