Télécharger chame1.eso

Retour à la liste

Numérotation des lignes :

chame1
  1. C CHAME1 SOURCE CB215821 20/11/25 13:19:15 10792
  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. C
  102. * write(6,*) 'chame1 ',ipmAIL,IPMODL,IPCHPO,CHA,ISUP
  103. * preconditionnement on regarde si on a sauve le resultat
  104. * on ne fait l'horodatage que pour le chp par mesure d'economie
  105. ith=oothrd
  106. call oooho1(ipchpo,ihochp)
  107. do 100 iprec=1,nprcha
  108. if (iprchp(iprec,ith).ne.ipchpo) goto 100
  109. if (iprma(iprec,ith).ne.ipmail) goto 100
  110. if (iprmo(iprec,ith).ne.ipmodl) goto 100
  111. if (iprhoc(iprec,ith).ne.ihochp) goto 100
  112. if (iprsu(iprec,ith).ne.isup ) goto 100
  113. if (iprcha(iprec,ith).ne.cha ) goto 100
  114. * preconditionnement trouve
  115. ipchel=iprchl(iprec,ith)
  116. ** if(ith.eq.1)
  117. ** > write(6,*) ' preconditionnement trouve ',iprec,ith,ipchel
  118. call actobj('MCHAML',ipchel,1)
  119. return
  120. 100 continue
  121.  
  122.  
  123.  
  124. IPARA1= 0
  125. IPARA2= 0
  126.  
  127. NT1 = 1
  128. NT2 = 1
  129. IOPTIM= 100
  130.  
  131. INFO = 0
  132. ISUP1 = ISUP
  133. IPCHEL= 0
  134. NPINT = 0
  135. VID1 =' '
  136.  
  137. ither = 0
  138. idiff = 0
  139. imeta = 0
  140.  
  141. C
  142. C on cree l'objet maillage contenant tous les points du chpoint
  143. C
  144. MCHPOI=IPCHPO
  145. NSOUPO=IPCHP(/1)
  146. C
  147. IF (IPMAIL.NE.0) THEN
  148. IPT1=IPMAIL
  149. NSOUS=IPT1.LISOUS(/1)
  150. IF (NSOUS.EQ.0) THEN
  151. NSOUS=1
  152. ENDIF
  153. ISUP1=1
  154. ELSE IF (IPMODL.NE.0) THEN
  155. MMODEL = IPMODL
  156. NSOUS = KMODEL(/1)
  157. ENDIF
  158. C
  159. C initialisation du segment descripteur du champ par element
  160. C
  161. N1=NSOUS
  162. N3=6
  163. MO1 = CHA(1:1)
  164. IF (MO1.EQ.VID1) THEN
  165. L1=8
  166. SOUTYP=MTYPOI
  167. ELSE
  168. L1=LEN(CHA)
  169. SOUTYP=CHA
  170. ENDIF
  171.  
  172. C Renvoi le nombre de composantes
  173. CALL NBCOMP(MCHPOI,'CHPOINT ',N2)
  174.  
  175. NX =0
  176. N2PTEL=0
  177. N2EL =0
  178. ISOUSs=0
  179.  
  180. C Dimensionnement de ISAUT
  181. IF(IPMODL .NE. 0)THEN
  182. IVAL=6
  183. ELSE
  184. IVAL=3
  185. ENDIF
  186.  
  187. IF(OOTHRD .NE.0) call oooprl(1)
  188. SEGINI,ICPR,ISAUT
  189. IF(OOTHRD .NE.0) call oooprl(0)
  190.  
  191. DO 19 ISOUS=1,NSOUS
  192. ISUP1 =ISUP
  193. IPMINT=0
  194. IF (IPMAIL.NE.0) THEN
  195. IF (NSOUS.GT.1) THEN
  196. IPT2=IPT1.LISOUS(ISOUS)
  197. ELSE
  198. IPT2=IPMAIL
  199. ENDIF
  200.  
  201. ELSEIF (IPMODL.NE.0) THEN
  202. IMODEL = KMODEL(ISOUS)
  203. c pour les elements MULT, on autorise que les MCHAML aux noeuds
  204. if(ISUP1.ne.1) then
  205. itest=nefmod
  206. if(itest.eq.22.OR.itest.eq.259) goto 19
  207. endif
  208. IPT2 = IMAMOD
  209.  
  210. if (formod(1)(1:8).eq.'LIAISON ') then
  211. C ne fait rien si le maillage de LIAISON n'appartient pas au CHPOINT
  212.  
  213. IVAL1 = IPT2.num(1,1)
  214. DO I=1,NSOUPO
  215. MSOUPO=IPCHP(I)
  216. MELEME=IGEOC
  217. do jno = 1, num(/2)
  218. if (num(1,jno).eq.IVAL1) goto 191
  219. enddo
  220. goto 19
  221. ENDDO
  222. endif
  223. 191 CONTINUE
  224.  
  225. IMODEL = KMODEL(ISOUS)
  226. IF(INFMOD(/1).NE.0) NPINT=INFMOD(1)
  227. C
  228. C Changment de support si besoin selon la formulation ?
  229. IF (ISUP1 .NE. 1) THEN
  230. NFOR = FORMOD(/2)
  231. CALL PLACE(FORMOD,NFOR,icont,'CONTACT ')
  232. CALL PLACE(FORMOD,NFOR,ichph,'CHANGEMENT_PHASE')
  233. IF (icont.NE.0 .OR. ichph.NE.0) THEN
  234. ISUP1 = 1
  235. ELSE
  236. CALL PLACE(FORMOD,NFOR,ither,'THERMIQUE')
  237. CALL PLACE(FORMOD,NFOR,idiff,'DIFFUSION')
  238. CALL PLACE(FORMOD,NFOR,imeta,'METALLURGIE')
  239. IF (ither.NE.0 .OR. idiff.NE.0 .OR. imeta.NE.0) THEN
  240. nmat = matmod(/2)
  241. CALL PLACE(matmod,nmat,iray,'RAYONNEMENT')
  242. C Support 6 SAUF pour le RAYONNEMENT...
  243. C Les cas-tests de RAYONNEMENT sont en erreur sans ca...
  244. IF (iray.EQ.0) ISUP1 = 6
  245. ENDIF
  246. ENDIF
  247. ENDIF
  248. C
  249. C on recupere le pointeur sur le minte correspondant a isup1
  250. C
  251. IF (ISUP1.GT.1) THEN
  252. MELE=NEFMOD
  253. IF ( ISUP1 .EQ. 6) THEN
  254. C cas de la THERMIQUE(sauf RAYONNEMENT) OU DIFFUSION OU METALLURGIE
  255. CALL TSHAPE(MELE,'GAUSS',IPMINT)
  256. IF (IERR.NE.0) RETURN
  257. IELE = NUMGEO(MELE)
  258. NBNN = NBNNE(IELE)
  259. ELSE
  260. if(2+isup1.gt.infmod(/1)) then
  261. CALL ELQUOI(MELE,0,ISUP1,INFO,IMODEL)
  262. IF (IERR.NE.0) RETURN
  263. IPMINT=INFELL(11)
  264. else
  265. IPMINT=infmod(2+isup1)
  266. IELE =INFELE(14)
  267. NBNN =NBNNE(IELE)
  268. endif
  269. C write(6,*) ' chame1 ipmint iele nbnn',ipmint,iele,nbnn
  270. ENDIF
  271. C
  272. C initialisation de ipore pour milieu poreux
  273. C
  274. IPORE=0
  275. IF(MELE.GE.79 .AND.MELE.LE.83 ) IPORE=NBNN
  276. IF(MELE.GE.173.AND.MELE.LE.177) IPORE=NBNN
  277. IF(MELE.GE.178.AND.MELE.LE.182) IPORE=NBNN
  278. C cas XFEM il faut seulement les 4 premier noeuds (support geometrique)
  279. IF(MELE.GE.263) IPORE=NBNN
  280.  
  281. ISAUT(4,ISOUS)=IPMINT
  282. IF(IPORE .EQ. 0)THEN
  283. MINTE =IPMINT
  284. ISAUT(5,ISOUS)=SHPTOT(/2)
  285. ELSE
  286. ISAUT(5,ISOUS)=IPORE
  287. ENDIF
  288. ENDIF
  289.  
  290. ISAUT(6,ISOUS)= ISUP1
  291.  
  292. ELSE
  293. CALL ERREUR(5)
  294. RETURN
  295. ENDIF
  296.  
  297. ISOUSs=ISOUSs+1
  298.  
  299. ISAUT(1,ISOUS) = IPT2
  300.  
  301. NBNO = IPT2.NUM(/1)
  302. N1EL = IPT2.NUM(/2)
  303.  
  304. C Remplissage de l'ICPR a partir des noeuds du MMODEL
  305. C L'utilisation d'un ICPR par MMODEL limite l'utilisation de
  306. C memoire en parallele des les ASSISTANTS
  307. DO 301 IEL=1,N1EL
  308. DO 302 INO=1,NBNO
  309. INOEU=IPT2.NUM(INO,IEL)
  310. IF(ICPR(INOEU) .NE. 0)GOTO 302
  311. NX=NX+1
  312. ICPR(INOEU)=NX
  313. 302 CONTINUE
  314. 301 CONTINUE
  315.  
  316. IF(IPMINT .EQ. 0)THEN
  317. N1PTEL=NBNO
  318. ELSE
  319. MINTE =IPMINT
  320. N1PTEL=SHPTOT(/3)
  321. ENDIF
  322.  
  323. ISAUT(2,ISOUSs) = N1EL
  324. ISAUT(3,ISOUSs) = N1PTEL
  325.  
  326. NT2 = MAX(NT2,N1EL*N1PTEL)
  327. 19 CONTINUE
  328.  
  329. C Creation d'un MAXIMUM de SEGMENTS dans un LOCK
  330. N1=ISOUSs
  331. IF(OOTHRD .NE.0) call oooprl(1)
  332. SEGINI,MCHELM
  333. DO ISOUSs=1,N1
  334. SEGINI,MCHAML
  335. ICHAML(ISOUSs)=MCHAML
  336. N1EL =ISAUT(2,ISOUSs)
  337. N1PTEL=ISAUT(3,ISOUSs)
  338. DO ICOMP=1,N2
  339. SEGINI,MELVAL
  340. IELVAL(ICOMP)=MELVAL
  341. ENDDO
  342. ENDDO
  343. SEGINI,MTRA2
  344. IF(OOTHRD .NE.0) call oooprl(0)
  345.  
  346. TITCHE=SOUTYP
  347. IFOCHE=IFOUR
  348.  
  349. NCO = 0
  350. DO ISOUPO=1,NSOUPO
  351. MSOUPO=IPCHP(ISOUPO)
  352. MELEME=IGEOC
  353. NT1 =MAX(NT1,NUM(/2))
  354. NC =MSOUPO.NOHARM(/1)
  355. DO 101 ICO=1,NC
  356. MOCOMP=MSOUPO.NOCOMP(ICO)
  357. DO K=1,NCO
  358. IF(MOCOMP .EQ. MTRA2.INCO(K))GOTO 101
  359. ENDDO
  360. NCO = NCO + 1
  361. K = NCO
  362. MTRA2.INCO(NCO)=MOCOMP
  363. 101 CONTINUE
  364. ENDDO
  365.  
  366. C----------------------------------------------------------------------C
  367. C Remplissage du MTRA2
  368. C----------------------------------------------------------------------C
  369. NBTHR=MIN(MAX(NT1/IOPTIM,1),NBTHRS)
  370. IF ((NBTHR .EQ. 1) .OR. (NBTHRS .EQ. 1) .OR. (OOTHRD .GT. 0)) THEN
  371. C CB215821 : DESACTIVE LA PARALLELISATION PTHREAD LORSQUE ON EST
  372. C DEJA DANS LES ASSISTANTS
  373. NBTHR = 1
  374. BTHRD = .FALSE.
  375. ELSE
  376. BTHRD = .TRUE.
  377. CALL THREADII
  378. ENDIF
  379.  
  380. IF (BTHRD) THEN
  381. C Remplissage du 'COMMON/cham1c'
  382. SEGINI,SPARA1
  383. IPARA1=SPARA1
  384. IPARA2=0
  385.  
  386. SPARA1.NBTHR1=NBTHR
  387. SPARA1.IPCH1 =MCHPOI
  388. SPARA1.IPTP1 =ICPR
  389. SPARA1.IPTR1 =MTRA2
  390.  
  391. DO ith=2,NBTHR
  392. CALL THREADID(ith,CHAM1i)
  393. ENDDO
  394. CALL CHAM1i(1)
  395.  
  396. C Attente de la fin de tous les threads en cours de travail
  397. DO ith=2,NBTHR
  398. CALL THREADIF(ith)
  399. ENDDO
  400.  
  401. C On libère les Threads
  402. CALL THREADIS
  403. SEGSUP,SPARA1
  404.  
  405. ELSE
  406. C Appel de la SUBROUTINE qui fait le travail
  407. ith=1
  408. CALL CHAM11(NBTHR,ith,MCHPOI,ICPR,MTRA2)
  409. ENDIF
  410.  
  411. C----------------------------------------------------------------------C
  412. C Remplissage du MCHAML
  413. C----------------------------------------------------------------------C
  414.  
  415.  
  416. NBTHR=MIN(MAX(NT2/IOPTIM,1),NBTHRS)
  417. IF ((NBTHR .EQ. 1) .OR. (NBTHRS .EQ. 1) .OR. (OOTHRD .GT. 0)) THEN
  418. C CB215821 : DESACTIVE LA PARALLELISATION PTHREAD LORSQUE ON EST
  419. C DEJA DANS LES ASSISTANTS
  420. NBTHR = 1
  421. BTHRD = .FALSE.
  422. ELSE
  423. BTHRD = .TRUE.
  424. CALL THREADII
  425. ENDIF
  426.  
  427. IF (BTHRD) THEN
  428. C Remplissage du 'COMMON/cham1c'
  429. SEGINI,SPARA2
  430. IPARA1=0
  431. IPARA2=SPARA2
  432.  
  433. SPARA2.NBTHRD=NBTHR
  434. SPARA2.IISUP =ISUP
  435. SPARA2.IPSAU =ISAUT
  436. SPARA2.IPMOD =IPMODL
  437. SPARA2.IPCHE =MCHELM
  438. SPARA2.IPTPR =ICPR
  439. SPARA2.IPTRA =MTRA2
  440.  
  441. DO ith=2,NBTHR
  442. CALL THREADID(ith,CHAM1i)
  443. ENDDO
  444. CALL CHAM1i(1)
  445.  
  446. C Attente de la fin de tous les threads en cours de travail
  447. DO ith=2,NBTHR
  448. CALL THREADIF(ith)
  449. ENDDO
  450.  
  451. C On libere les Threads
  452. CALL THREADIS
  453. SEGSUP,SPARA2
  454.  
  455. ELSE
  456. C Appel de la SUBROUTINE qui fait le travail
  457. ith=1
  458. CALL CHAM12(NBTHR,ith,ISUP,ISAUT,IPMODL,MCHELM,ICPR,MTRA2)
  459. ENDIF
  460.  
  461. SEGSUP,MTRA2,ISAUT,ICPR
  462. IF(INFO .NE. 0)SEGSUP,INFO
  463.  
  464. IPCHEL=MCHELM
  465. * preconditionnement on garde l'operation en memoire
  466. ith=oothrd
  467. do iprec=nprcha,2,-1
  468. iprma(iprec,ith) =iprma(iprec-1,ith)
  469. iprmo(iprec,ith) =iprmo(iprec-1,ith)
  470. iprchp(iprec,ith)=iprchp(iprec-1,ith)
  471. iprhoc(iprec,ith)=iprhoc(iprec-1,ith)
  472. iprsu(iprec,ith) =iprsu(iprec-1,ith)
  473. iprcha(iprec,ith)=iprcha(iprec-1,ith)
  474. iprchl(iprec,ith)=iprchl(iprec-1,ith)
  475. enddo
  476. iprma(1,ith) =ipmail
  477. iprmo(1,ith) =ipmodl
  478. iprchp(1,ith)=ipchpo
  479. iprhoc(1,ith)=ihochp
  480. iprsu(1,ith) =isup
  481. iprcha(1,ith)=cha
  482. iprchl(1,ith)=ipchel
  483. ** write(6,*) ' preconditionnement de ',ipchel
  484.  
  485. END
  486.  
  487.  
  488.  
  489.  
  490.  
  491.  
  492.  
  493.  
  494.  

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