Télécharger chasup.eso

Retour à la liste

Numérotation des lignes :

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

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