Télécharger chasup.eso

Retour à la liste

Numérotation des lignes :

  1. C CHASUP SOURCE CB215821 19/08/20 21:15:42 10287
  2. SUBROUTINE CHASUP(IPMODL,IPOI1,IPOI2,IRET,IPLAC)
  3. C---------------------------------------------------------------------
  4.  
  5. C ENTREES:
  6. C
  7. C IPMODL Pointeur sur un MMODEL
  8. C IPOI1 Pointeur sur un MCHAML
  9. C IPLAC Indique le type de support demandé :
  10. C 1 scalaire aux NOEUDS
  11. C 2 scalaire au CENTRE DE GRAVITE
  12. C 3 scalaire aux points d'integration de la RAIDEUR
  13. C 4 scalaire aux points d'integration de la MASSE
  14. C 5 scalaire aux points de CONTRAINTES
  15. C
  16. C AM 14/6/07 SI IPLAC EST NEGATIF, ON RECUPERE UN CHAMP QUI
  17. C NE CONTIENT PAS LES COMPOSANTES COMPLEXES (NON SCALAIRES)
  18. C QU'ON A N'A PAS PU CHANGER
  19. C SINON, ON SORT EN ERREUR
  20. C
  21. C SORTIE:
  22. C
  23. C IPOI2 Pointeur sur un MCHAML
  24. C IRET =0 Si tout est ok
  25. C Sinon contient le numero d'erreur
  26. C
  27. C I.MONNIER le 31.05.90
  28. C
  29. C---------------------------------------------------------------------
  30. IMPLICIT INTEGER(I-N)
  31. IMPLICIT REAL*8(A-H,O-Z)
  32. -INC CCOPTIO
  33. -INC SMMODEL
  34. -INC SMCHAML
  35. -INC SMELEME
  36. -INC SMINTE
  37. -INC SMCOORD
  38. CHARACTER*8 CHARIN,CHARTY,MO8,MO24a,MO24b
  39. C
  40. SEGMENT SWORK
  41. REAL*8 VAL1(NBPGA1),VAL2(NBPGAU),VALN(NBNN)
  42. REAL*8 SHP(6,NBNN) ,XE(3,NBNN)
  43. ENDSEGMENT
  44. C
  45. SEGMENT SWORK2
  46. INTEGER LETAB(N22)
  47. ENDSEGMENT
  48. *
  49. * NBPGA1,NBPGAU DESIGNENT LES TAILLES MAX DES CHAMPS CH1 ET CH2
  50. * N1PTE1,N1PTEL DESIGNENT LES TAILLES EFFECTIVES DE CES CHAMPS
  51. *
  52. SEGMENT INFO
  53. INTEGER INFELL(JG)
  54. ENDSEGMENT
  55. C
  56. IRET =0
  57. IPOIN1=0
  58. C
  59. C ACTIVATION DU MODELE
  60. C
  61. MMODEL=IPMODL
  62. NSOUS1=KMODEL(/1)
  63. C
  64. C ACTIVATION DES MCHELM
  65. C
  66. MCHEL1 =IPOI1
  67. NSOUS=MCHEL1.ICHAML(/1)
  68. IF(NSOUS.GT.NSOUS1)THEN
  69. * on va essayer de reduir le champ
  70. call reduaf(mchel1,mmodel,mchel2,0,ire,kerre)
  71. ** if (ire.ne.1) then
  72. ** call erreur(kerre)
  73. ** IRET=553
  74. ** RETURN
  75. ** endif
  76. if (ire.eq.1) mchel1=mchel2
  77. NSOUS=MCHEL1.ICHAML(/1)
  78. ENDIF
  79. N1=NSOUS
  80. L1=MCHEL1.TITCHE(/1)
  81. N3=MCHEL1.INFCHE(/2)
  82. NINF=N3
  83. IF (N3.LT.6) N3=6
  84. SEGINI MCHELM
  85. TITCHE=MCHEL1.TITCHE
  86. IFOCHE=IFOUR
  87. IPOI2=MCHELM
  88. iresu=0
  89. C
  90. C ON BOUCLE SUR LES SOUS-ZONES DU MCHAML
  91. C
  92. DO 100 ISOUS=1,NSOUS
  93. *
  94. IMACHE(ISOUS)=MCHEL1.IMACHE(ISOUS)
  95. CONCHE(ISOUS)=MCHEL1.CONCHE(ISOUS)
  96. DO 191 IP=1,NINF
  97. INFCHE(ISOUS,IP)=MCHEL1.INFCHE(ISOUS,IP)
  98. 191 CONTINUE
  99. C
  100. C MISE EN CONCORDANCE DES POINTEURS DE MAILLAGE
  101. C
  102. MELEME=IMACHE(ISOUS)
  103. INS=0
  104. DO 151 IO=1,NSOUS1
  105. IMODEL=KMODEL(IO)
  106. CALL PLACE(FORMOD,FORMOD(/2),IDARC,'DARCY ')
  107. IPMAIL=IMAMOD
  108. C
  109. C CAS DE LA FORMULATION DARCY ON VA EXTRAIRE LE MAILLAGE SOMMET
  110. IF(IDARC.NE.0)THEN
  111. CALL LEKMOD(MMODEL,IPTABL,INEFMD)
  112. CHARIN = 'MAILLAGE'
  113. CALL LEKTAB(IPTABL,CHARIN, IOBRE)
  114. IF (IERR.NE.0) RETURN
  115. IPT1 = IOBRE
  116. IPMAIL= IOBRE
  117. IF(N1.GT.1.and.ipt1.lisous(/1).ge.n1)THEN
  118. IPMAIL= IPT1.LISOUS(ISOUS)
  119. ENDIF
  120. ENDIF
  121. IF (IPMAIL.EQ.MELEME) INS=INS+1
  122. 151 CONTINUE
  123. DO 150 IO=1,NSOUS1
  124. IMODEL=KMODEL(IO)
  125. CALL PLACE(FORMOD,FORMOD(/2),IDARC,'DARCY ')
  126. IPMAIL=IMAMOD
  127. C
  128. C CAS DE LA FORMULATION DARCY ON VA EXTRAIRE LE MAILLAGE SOMMET
  129. IF(IDARC.NE.0)THEN
  130. CALL LEKMOD(MMODEL,IPTABL,INEFMD)
  131. CHARIN = 'MAILLAGE'
  132. CALL LEKTAB(IPTABL,CHARIN, IOBRE)
  133. IF (IERR.NE.0) RETURN
  134. IPT1 = IOBRE
  135. IPMAIL= IOBRE
  136. IF(N1.GT.1.and.ipt1.lisous(/1).ge.n1)THEN
  137. IPMAIL= IPT1.LISOUS(ISOUS)
  138. ENDIF
  139. ENDIF
  140. MO24a=CONCHE(ISOUS)
  141. MO24b=CONMOD
  142. IF (IPMAIL.EQ.MELEME.AND.(INS.GE.1.OR.MO24a.EQ.MO24b))GOTO 160
  143. 150 CONTINUE
  144. *
  145. IRET=472
  146. SEGSUP MCHELM
  147. RETURN
  148. *
  149. 160 MELE=NEFMOD
  150.  
  151. * write(6,*) 'mele ',mele
  152. * on saute si element sans les supports
  153. if(mele.eq.22 ) go to 100
  154. if(mele.eq.259) go to 100
  155. if(mele.eq.107) go to 100
  156. if(mele.eq.165) go to 100
  157. if(mele.eq.261) go to 100
  158.  
  159. *
  160. * DANS LE CAS DES COQUES INTEGREES ON SORT EN ERREUR
  161. *
  162. IF (NINF.LT.4.OR.MCHEL1.INFCHE(ISOUS,4).EQ.0) THEN
  163. MINTE1=0
  164. IPLACA=0
  165. ELSE
  166. MINTE1=MCHEL1.INFCHE(ISOUS,4)
  167. IPLACA=MCHEL1.INFCHE(ISOUS,6)
  168. ENDIF
  169. * write(6,*) 'chasup minte1 ninf', ninf,minte1
  170. C
  171. if (formod(1).eq.'LIAISON ') then
  172. IPLAC1 = 1
  173. else
  174. IPLAC1 = ABS(IPLAC)
  175. C le modele contient t il de la thermique OU diffusion OU metallurgie ?
  176. C ==> le segment d'integration est particulier
  177. IF ( FORMOD(1).EQ.'THERMIQUE ' .OR.
  178. & FORMOD(1).EQ.'DIFFUSION ' .OR.
  179. & FORMOD(1).EQ.'METALLURGIE ' ) THEN
  180. nmat = matmod(/2)
  181. icov = 0
  182. C* CALL PLACE(matmod,nmat,icov,'CONVECTION')
  183. CALL PLACE(matmod,nmat,iray,'RAYONNEMENT ')
  184. IF (icov+iray.EQ.0) THEN
  185. IF ( IPLAC1 .NE. 1 ) IPLAC1 = 6
  186. ENDIF
  187. ENDIF
  188. endif
  189. C
  190. IF(IPLAC1.EQ.6)THEN
  191. CALL TSHAPE(MELE,'GAUSS',IPMINT)
  192. IF ( IERR .NE. 0) GOTO 665
  193. MINTE=IPMINT
  194. MELGEO=NUMGEO(MELE)
  195. ELSE
  196. if(2+iplac1.gt.infmod(/1))then
  197. CALL ELQUOI(MELE,0,IPLAC1,IPTR2,IMODEL)
  198. IF ( IERR .NE. 0) GOTO 665
  199. INFO=IPTR2
  200. MINTE=INFELL(11)
  201. MELGEO=INFELL(14)
  202. SEGSUP,INFO
  203. else
  204. minte=infmod(2+iplac1)
  205. MELGEO=INFELE(14)
  206. endif
  207. * write(6,*) ' apres zelquoi minte' , minte
  208. ENDIF
  209. INFCHE(ISOUS,4)=MINTE
  210. IF(IPLAC1.EQ.1)INFCHE(ISOUS,4)=0
  211. INFCHE(ISOUS,6)=IPLAC1
  212. C
  213. C ON RECUPERE LE NOMBRE D ELEMENTS
  214. C
  215. NBNN =NUM(/1)
  216. NBELEM=NUM(/2)
  217. C
  218. C ON RECUPERE LE NOMBRE DE POINTS SUPPORT
  219. C NBPGA1 POUR L'ANCIEN CHAMP ET NBPGAU POUR LE NOUVEAU
  220. C
  221. IF(MINTE1.NE.0)THEN
  222. NBPGA1 = MINTE1.SHPTOT(/3)
  223. ELSE
  224. NBPGA1=NBNN
  225. ENDIF
  226. if (minte.eq.0) then
  227. call erreur(5)
  228. return
  229. endif
  230. NBPGAU = SHPTOT(/3)
  231. nbpga1=max(nbpga1,nbpgau)
  232. * write(6,*) ' nbpgau,nbpga1',nbpgau,nbpga1
  233. C
  234. NEL =NBELEM
  235. SEGINI SWORK
  236. C
  237. C PREPARATION POUR CREATION DU MCHAML
  238. C
  239. MCHAM1=MCHEL1.ICHAML(ISOUS)
  240. C
  241. N22 = MCHAM1.NOMCHE(/2)
  242. *
  243. * SI IPLAC < 0, ON CHERCHE LE NOMBRE DE COMPOSANTES A CONSERVER
  244. *
  245. SEGINI SWORK2
  246. *
  247. IF(IPLAC.GE.0) THEN
  248. N2 = N22
  249. DO ICOMP=1,N22
  250. LETAB(ICOMP) = ICOMP
  251. ENDDO
  252. *
  253. ELSE
  254. *
  255. * BOUCLE SUR LES COMPOSANTES
  256. *
  257. JECO = 0
  258. DO 170 ICOMP=1,N22
  259. C
  260. CHARTY=MCHAM1.TYPCHE(ICOMP)
  261. MELVA1=MCHAM1.IELVAL(ICOMP)
  262. LETAB(ICOMP) = 0
  263. *
  264. IF(CHARTY(1:6).EQ.'REAL*8') THEN
  265. JECO = JECO + 1
  266. LETAB(ICOMP) = JECO
  267. ENDIF
  268. *
  269. * cas de variables complexes
  270. *
  271. IF(CHARTY(1:8).EQ.'POINTEUR') THEN
  272. N2PTE1=MELVA1.IELCHE(/1)
  273. *
  274. * ... Comme on ne sait pas extrapoler ou interpoler de variables
  275. * composées, on n'en accepte qu'une par élément ...
  276.  
  277. IF(N2PTE1.EQ.1) THEN
  278. JECO = JECO + 1
  279. LETAB(ICOMP) = JECO
  280. ENDIF
  281. ENDIF
  282. 170 CONTINUE
  283. N2 = JECO
  284. *
  285. ENDIF
  286. *
  287. * CREATION DU MCHAML
  288. *
  289. SEGINI MCHAML
  290. iresu=iresu+1
  291. ICHAML(iresu)=MCHAML
  292. C
  293. C BOUCLE SUR LES COMPOSANTES EN ENTREE
  294. C
  295. DO 180 ICOMP=1,N22
  296. C
  297. JCOMP = LETAB(ICOMP)
  298. IF(JCOMP.EQ.0) GO TO 180
  299.  
  300. NOMCHE(JCOMP)=MCHAM1.NOMCHE(ICOMP)
  301. TYPCHE(JCOMP)=MCHAM1.TYPCHE(ICOMP)
  302. C
  303. MELVA1=MCHAM1.IELVAL(ICOMP)
  304. * write (6,*) ' dans chasup melva1 ',melva1
  305. *
  306. * RECHERCHE DES TAILLES DU NOUVEAU CHAMELEM - dans le cas scalaire
  307. *
  308. IF(TYPCHE(JCOMP)(1:6).EQ.'REAL*8') THEN
  309. N1PTE1=MELVA1.VELCHE(/1)
  310. IF (N1PTE1.EQ.1) THEN
  311. N1PTEL=1
  312. ELSE
  313. N1PTEL=NBPGAU
  314. ENDIF
  315. N1EL =MELVA1.VELCHE(/2)
  316. *
  317. * PETIT TEST DE COMPATIBILITE DES NOMBRES D'ELEMENTS
  318. *
  319. IF(N1EL.NE.NEL.AND.N1EL.NE.1.AND.NEL.NE.1) THEN
  320. SEGSUP SWORK,SWORK2,MCHAML
  321. IRET=146
  322. MOTERR(1:8)='CHASUP '
  323. GO TO 665
  324. ENDIF
  325. *
  326. N1PAUX=N1PTE1
  327. C
  328. C-----------------------------------------------------------------------
  329. C PETIT TEST POUR LE COQ4
  330. C SI LE NOMBRE DE POINTS DE GAUSS VAUT 5 , ON NE PREND QUE
  331. C LES 4 PREMIERS , LE 5-EME SERVANT UNIQUEMENT AU CISAILLEMENT
  332. C
  333. IF (MELE.EQ.49.AND.N1PAUX.EQ.5) N1PAUX=4
  334. C-----------------------------------------------------------------------
  335. C
  336. ELSE
  337. N1PTEL=0
  338. N1EL=0
  339. ENDIF
  340. *
  341. * ... Et dans le cas de variables complexes ...
  342. *
  343. IF(TYPCHE(JCOMP)(1:8).EQ.'POINTEUR') THEN
  344. N2PTE1=MELVA1.IELCHE(/1)
  345. IF (N2PTE1.EQ.1) THEN
  346. N2PTEL=1
  347. ELSE
  348. N2PTEL=NBPGAU
  349. ENDIF
  350. N2EL =MELVA1.IELCHE(/2)
  351. *
  352. * ... Comme on ne sait pas extrapoler ou interpoler de variables
  353. * composées, on n'en accepte qu'une par élément ...
  354.  
  355. * IF(N2PTEL.NE.1) THEN
  356. * SEGSUP SWORK,SWORK2,MCHAML
  357. * IRET=755
  358. * GO TO 665
  359. * ENDIF
  360. *
  361. * PETIT TEST DE COMPATIBILITE DES NOMBRES D'ELEMENTS
  362. *
  363. IF(N2EL.NE.NEL.AND.N2EL.NE.1.AND.NEL.NE.1) THEN
  364. SEGSUP SWORK,SWORK2,MCHAML
  365. IRET=146
  366. MOTERR(1:8)='CHASUP '
  367. GO TO 665
  368. ENDIF
  369.  
  370. ELSE
  371. N2PTEL=0
  372. N2EL=0
  373. ENDIF
  374. SEGINI MELVAL
  375. IELVAL(JCOMP)=MELVAL
  376. *
  377. * TRAITEMENT IMMEDIAT SI CHAMP CONSTANT
  378. *
  379. * if(iplac1.eq.4) write(6,*)' n2ptel n1ptel',n2ptel,n1ptelq
  380. IF(n2ptel.ne.0) then
  381. IF(N2PTEL.EQ.1) THEN
  382. DO 4119 IEL=1,N2EL
  383. IELCHE(1,IEL)=MELVA1.IELCHE(1,IEL)
  384. 4119 CONTINUE
  385. C* ELSE IF (N2PTEL.NE.1) THEN
  386. ELSE
  387. IF (MINTE.NE.MINTE1. AND. IPLAC1.NE.IPLACA) THEN
  388. SEGSUP SWORK,SWORK2,MCHAML
  389. IRET=755
  390. GO TO 665
  391. ENDIF
  392. DO 4109 IGAU=1,N2PTEL
  393. DO 4109 IEL=1,N2EL
  394. IELCHE(IGAU,IEL)=MELVA1.IELCHE(IGAU,IEL)
  395. 4109 CONTINUE
  396. ENDIF
  397. else
  398. IF(N1PTE1.EQ.1) THEN
  399. DO 4120 IEL=1,N1EL
  400. VELCHE(1,IEL)=MELVA1.VELCHE(1,IEL)
  401. 4120 CONTINUE
  402. *
  403. ELSE
  404. *
  405. * write (6,*) melva1.velche(/1),melva1.velche(/2)
  406.  
  407. DO 3120 IEL=1,NEL
  408. IF(IEL.GT.1.AND.N1EL.EQ.1) GO TO 3130
  409. DO 3121 IGAU=1,N1PTE1
  410. VAL1(IGAU)=MELVA1.VELCHE(IGAU,IEL)
  411. 3121 CONTINUE
  412.  
  413. * write(6,*) 'MINTE1 = ',minte1
  414.  
  415. C
  416. C 1-ER CAS : LE CHAMELEM N'EST PAS AUX NOEUDS
  417. C
  418. IF(MINTE1.NE.0)THEN
  419. C
  420. C MEME SUPPORT? ( attention test sur iplaca et iplac1 pour DKT)
  421. C
  422. * write(6,*) ' meme support?',minte,minte1,iplac1,iplaca
  423. IF(MINTE.EQ.MINTE1. OR. IPLAC1.eq.IPLACA) THEN
  424. DO 3124 IGAU=1,N1PTE1
  425. VELCHE(IGAU,IEL)=VAL1(IGAU)
  426. 3124 CONTINUE
  427. C
  428. C SUPPORTS DIFFERENTS
  429. C
  430. ELSE
  431. C
  432. C COQUE INTEGREE OU PAS ?
  433. C
  434. IF(INFMOD(/1).NE.0)THEN
  435. NPINT=INFMOD(1)
  436. ELSE
  437. NPINT=0
  438. ENDIF
  439. IF (NPINT.NE.0.AND.NPINT.NE.1)THEN
  440. IRET = 19
  441. SEGSUP SWORK,SWORK2,MCHAML,MELVAL
  442. GO TO 665
  443. ENDIF
  444. C
  445. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IEL,XE)
  446. CALL QUEDIM(MELGEO,KERRE)
  447. CALL CH1CH2(MELE,MINTE,MINTE1,N1PTEL,N1PAUX,NBNN,
  448. & SWORK,IPOIN1,KERRE)
  449. IF(KERRE.NE.0) THEN
  450. IRET=KERRE
  451. SEGSUP SWORK,SWORK2,MCHAML,MELVAL
  452. GO TO 665
  453. ENDIF
  454. *
  455. DO 3122 IGAU=1,N1PTEL
  456. VELCHE(IGAU,IEL)=VAL2(IGAU)
  457. 3122 CONTINUE
  458. ENDIF
  459. C
  460. C 2-EME CAS : LE CHAMELEM EST AUX NOEUDS
  461. C
  462. ELSE
  463. *
  464. * AM 1/4/16 CAS PARTICULIER DES JOINTS
  465. *
  466. IF( MELGEO.EQ.12.OR.MELGEO.EQ.13
  467. & .OR.MELGEO.EQ.29.OR.MELGEO.EQ.30
  468. & .OR.MELGEO.EQ.31) THEN
  469. *
  470. IF(((IPLACA.EQ.0.OR.IPLACA.EQ.1).AND.IPLAC1.EQ.1)
  471. & .AND.(N1PTEL.EQ.N1PTE1)) THEN
  472. DO 3115 IGAU=1,N1PTE1
  473. VELCHE(IGAU,IEL)=VAL1(IGAU)
  474. 3115 CONTINUE
  475. ELSE
  476. *
  477. IDECA=0
  478. IF(MELGEO.EQ.29) IDECA=2
  479. IF(MELGEO.EQ.30) IDECA=3
  480. IF(MELGEO.EQ.31) IDECA=4
  481. NBNOU=NBNN-IDECA
  482. NBNOV=SHPTOT(/2)-IDECA
  483. *
  484. MO8=NOMCHE(JCOMP)
  485. IF(MO8.EQ.'P '.OR.
  486. & MO8.EQ.'PQ '.OR.
  487. & MO8.EQ.'TP ' ) THEN
  488. DO 3117 IGAU=1,N1PTEL
  489. VALG=0.D0
  490. DO 3116 INO=1,IDECA
  491. INO1 = NBNOU + INO
  492. INO2 = NBNOV + INO
  493. VALG=VALG+SHPTOT(1,INO2,IGAU)*VAL1(INO1)
  494. 3116 CONTINUE
  495. VELCHE(IGAU,IEL)=VALG
  496. 3117 CONTINUE
  497. *
  498. ELSE
  499. DO 3119 IGAU=1,N1PTEL
  500. VALG=0.D0
  501. DO 3118 INO=1,NBNOU
  502. VALG=VALG+SHPTOT(1,INO,IGAU)*VAL1(INO)
  503. 3118 CONTINUE
  504. VELCHE(IGAU,IEL)=VALG/2.D0
  505. 3119 CONTINUE
  506. ENDIF
  507. ENDIF
  508. *
  509. ELSE
  510. *
  511. DO 3123 IGAU=1,N1PTEL
  512. VALG=0.D0
  513. DO 3125 INO=1,NBNN
  514. VALG=VALG+SHPTOT(1,INO,IGAU)*VAL1(INO)
  515. 3125 CONTINUE
  516. VELCHE(IGAU,IEL)=VALG
  517. 3123 CONTINUE
  518. ENDIF
  519.  
  520. ENDIF
  521. 3120 CONTINUE
  522. 3130 CONTINUE
  523. *
  524. ENDIF
  525. endif
  526. 180 CONTINUE
  527. SEGSUP SWORK,SWORK2
  528. *
  529. 100 CONTINUE
  530. if (iresu.ne.nsous) then
  531. n1=iresu
  532. segadj mchelm
  533. endif
  534. 665 CONTINUE
  535. END
  536.  
  537.  
  538.  

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