Télécharger chasup.eso

Retour à la liste

Numérotation des lignes :

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

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