Télécharger deco1.eso

Retour à la liste

Numérotation des lignes :

  1. C DECO1 SOURCE BP208322 15/06/22 21:16:59 8543
  2. SUBROUTINE DECO1(IPMODL,IPCHE2,IPCHE1,IPCHL1,IRET)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5. *____________________________________________________________________*
  6. * *
  7. * Sous-programme de l'op{rateur DECO *
  8. * *
  9. * Entr{es: *
  10. * *
  11. * IPMODL Pointeur sur un objet MMODEL *
  12. * IPCHE2 Pointeur sur un MCHAML de FONCTION DE COURANT *
  13. * IPCHE1 Pointeur sur un MCHAML de CARACTERISTIQUES *
  14. * *
  15. * Sortie: *
  16. * *
  17. * IPCHL1 Pointeur sur un MCHAML de courants *
  18. * IRET 1 si succes , 0 sinon *
  19. * *
  20. * Auteurs, date de cr{ation: *
  21. * *
  22. * Yann Stephan, le 22/09/97 *
  23. * *
  24. *____________________________________________________________________*
  25. *
  26. -INC CCOPTIO
  27. -INC CCHAMP
  28. -INC SMCHAML
  29. -INC SMMODEL
  30. -INC SMELEME
  31. -INC SMINTE
  32. -INC SMCOORD
  33. *
  34. SEGMENT,MMAT1
  35. REAL*8 VALMAT(NMATR)
  36. REAL*8 XE(3,NBNN),XE1(3,NBNN)
  37. REAL*8 SHP(6,NBNN),GRAD(NDIM,NBNN,NBPGAU)
  38. REAL*8 COSD1(3),COSD2(3)
  39. ENDSEGMENT
  40. POINTEUR MMAT2.MMAT1,MMATX.MMAT1
  41. *
  42. SEGMENT SGAUSS
  43. REAL*8 XGAUSS(3,NBPGAU)
  44. REAL*8 DX(NBPGAU)
  45. ENDSEGMENT
  46. POINTEUR SGX.SGAUSS,SGY.SGAUSS
  47. *
  48. SEGMENT,MWRK1
  49. REAL*8 XDDL(LRE)
  50. ENDSEGMENT
  51. *
  52. SEGMENT INFO
  53. INTEGER INFELL(JG)
  54. ENDSEGMENT
  55. *
  56. SEGMENT NOTYPE
  57. CHARACTER*16 TYPE(NBTYPE)
  58. ENDSEGMENT
  59. *
  60. SEGMENT MPTVAL
  61. INTEGER IPOS(NS) ,NSOF(NS)
  62. INTEGER IVAL(NCOSOU)
  63. CHARACTER*16 TYVAL(NCOSOU)
  64. ENDSEGMENT
  65. *
  66. CHARACTER*8 CMATE
  67. CHARACTER*(NCONCH) CONM
  68. PARAMETER ( NINF=3 )
  69. INTEGER INFOS(NINF)
  70. LOGICAL lsupgd
  71. *
  72. IRET=1
  73. MWRK1=0
  74. NMAT = 0
  75. ITHER= 0
  76. IMAGN= 0
  77. NHRM = NIFOUR
  78. *
  79. * ACTIVATION DU CHAPEAU DE MODELE
  80. *
  81. MMODEL = IPMODL
  82. SEGACT MMODEL
  83. NSOUS = KMODEL(/1)
  84. *
  85. * Initialisation du CHAMELEM de COURANTS
  86. *
  87. L1 = 8
  88. N1 = NSOUS
  89. N3 = 6
  90. SEGINI,MCHELM
  91. IPCHL1=MCHELM
  92. TITCHE = 'COURANT'
  93. IFOCHE=IFOUR
  94. *
  95. * Boucle sur les zones {l{mentaires du MODELE
  96. *
  97. DO 500 ISOUS=1,NSOUS
  98. *
  99. * QUELQUES INITIALISATIONS
  100. *
  101. NGRA=0
  102. NDEP=0
  103. NCAR = 0
  104. IPMINT=0
  105. IRTD1=1
  106. NSTRS=0
  107. MOGRAD=0
  108. MODEPL=0
  109. MOTEMP=0
  110. MOCARA=0
  111. MOMATR=0
  112. IVAGRA=0
  113. IVADEP=0
  114. IVACAR=0
  115. IVAMAT=0
  116. NMATR=0
  117. NMATF=0
  118. *
  119. IMODEL=KMODEL(ISOUS)
  120. SEGACT IMODEL
  121. MELE=NEFMOD
  122. IPMAIL=IMAMOD
  123. CONM =CONMOD
  124. NFOR=FORMOD(/2)
  125. NMAT=MATMOD(/2)
  126. CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INAT)
  127. IF (CMATE.EQ.' ')THEN
  128. CALL ERREUR(251)
  129. SEGDES IMODEL,MMODEL
  130. SEGSUP MCHELM
  131. IRET=0
  132. RETURN
  133. ENDIF
  134. CALL PLACE(FORMOD,FORMOD(/2),IMAGN,'MAGNETODYNAMIQUE')
  135. *
  136. * ACTIVATION DU MAILLAGE
  137. *
  138. MELEME=IPMAIL
  139. SEGACT,MELEME
  140. NBNN =NUM(/1)
  141. NBELEM=NUM(/2)
  142. NBNO=NBNN
  143. *
  144. * INFORMATIONS SUR L'ELEMENT FINI
  145. *
  146. *
  147. IF(IMAGN.NE.0) THEN
  148. *
  149. * CAS MAGNETODYNAMIQUE
  150. *
  151. if(infmod(/1).lt.4) then
  152. CALL ELQUOI(MELE,0,2,IPINF,IMODEL)
  153. *
  154. IF (IERR.NE.0) THEN
  155. SEGDES IMODEL,MMODEL
  156. SEGSUP MCHELM
  157. IRET=0
  158. RETURN
  159. ENDIF
  160. INFO=IPINF
  161. MFR=INFELL(13)
  162. MINTE=INFELL(11)
  163. MINTE1= INFELL(12)
  164. NSTRS =INFELL(16)
  165. LW = INFELL( 7)
  166. LRE = INFELL( 9)
  167. LHOOK =INFELL(10)
  168. * SEGSUP INFO
  169. ELSE
  170. MFR=INFELE(13)
  171. minte=infmod(4)
  172. MINTE1= INFMOD(8)
  173. NSTRS =INFELE(16)
  174. LW = INFELE( 7)
  175. LRE = INFELE( 9)
  176. LHOOK =INFELE(10)
  177. ENDIF
  178. *
  179. ENDIF
  180. *
  181. * ACTIVATION DU SEGMENT D'INTEGRATION
  182. *
  183. SEGACT,MINTE
  184. NBPGAU=POIGAU(/1)
  185. SEGINI SGAUSS
  186. NDIM=IDIM
  187. SEGINI MMAT1
  188. C
  189. C CREATION DU TABLEAU INFOS
  190. C
  191. CALL IDENT(IPMAIL,CONM,IPCHE2,IPCHE1,INFOS,IRTD)
  192. IF (IRTD.EQ.0) GOTO 9990
  193. *
  194. * NOMS DE COMPOSANTES OBLIGATOIRES A TROUVER DANS LES CHAMELEMS
  195. *
  196. MDM=MFR
  197. if(lnomid(3).ne.0) then
  198. nomid=lnomid(3)
  199. segact nomid
  200. mograd=nomid
  201. ngra=lesobl(/2)
  202. nfac=lesfac(/2)
  203. lsupgd=.false.
  204. else
  205. IF(IMAGN.NE.0) MDM=69
  206. lsupgd=.true.
  207. CALL IDGRAD(MDM,IFOUR,MOGRAD,NGRA,NFAC)
  208. endif
  209. *
  210. IF(IMAGN.NE.0) THEN
  211. CALL IDFC(MFR,IFOUR,MOFC,NDEP,NFAC)
  212. ENDIF
  213. *
  214. * EPAISSEUR ET EXCENTREMENT DANS LE CAS DES COQUES
  215. *
  216. NBROBL=0
  217. NBRFAC=0
  218. MOCARA=0
  219. NCAR=0
  220. *
  221. IF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN
  222. NBROBL=1
  223. NBRFAC=1
  224. SEGINI NOMID
  225. MOCARA=NOMID
  226. LESOBL(1)='EPAI'
  227. LESFAC(1)='EXCE'
  228. NCAR=1
  229. ENDIF
  230. *
  231. * VERIFICATION DE PRESENCE DES COMPOSANTES
  232. *
  233. NBTYPE=1
  234. SEGINI NOTYPE
  235. MOTYPE=NOTYPE
  236. TYPE(1)='REAL*8'
  237. IF(IMAGN.NE.0) THEN
  238. CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOFC,
  239. 1 MOTYPE,1,INFOS,3,IVADEP)
  240. ENDIF
  241. SEGSUP NOTYPE
  242. IF (IERR.NE.0) THEN
  243. NGRA=0
  244. IF (NCAR.NE.0) THEN
  245. NOMID=MOCARA
  246. SEGSUP NOMID
  247. ENDIF
  248. MOCARA=0
  249. NCAR=0
  250. GOTO 9990
  251. ENDIF
  252. *
  253. IF (NCAR.NE.0) THEN
  254. IF (IPCHE1.NE.0) THEN
  255. NBTYPE=1
  256. SEGINI NOTYPE
  257. MOTYPE=NOTYPE
  258. TYPE(1)='REAL*8'
  259. CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCARA,MOTYPE,
  260. 1 1,INFOS,3,IVACAR)
  261. SEGSUP NOTYPE
  262. ELSE
  263. MOTERR(1:8)='CARACTER'
  264. MOTERR(9:12)=NOMTP(MELE)
  265. MOTERR(13:20)='COURANT'
  266. CALL ERREUR(145)
  267. NCAR=0
  268. NGRA=0
  269. NOMID=MOCARA
  270. SEGSUP NOMID
  271. MOCARA=0
  272. GOTO 9990
  273. ENDIF
  274. ENDIF
  275. IF (IERR.NE.0) GOTO 9990
  276. *
  277. IF(IVACAR.NE.0)THEN
  278. MPTVAL=IVACAR
  279. IPMELV=IVAL(1)
  280. CALL QUELCH(IPMELV,ICONS)
  281. IF(ICONS.NE.0)THEN
  282. CALL ERREUR(566)
  283. GOTO 9990
  284. ENDIF
  285. ENDIF
  286. *
  287. *
  288. NBROBL=0
  289. NBRFAC=0
  290. MOMATR=0
  291. NMATR=0
  292. NMATF=0
  293. *
  294. * CREATION DU MCHAML DE COURANT
  295. *
  296. N2=NGRA
  297. SEGINI,MCHAML
  298. ICHAML(ISOUS)=MCHAML
  299. IMACHE(ISOUS)=MELEME
  300. CONCHE(ISOUS)=CONMOD
  301. C
  302. INFCHE(ISOUS,1)=0
  303. INFCHE(ISOUS,2)=0
  304. INFCHE(ISOUS,3)=NHRM
  305. INFCHE(ISOUS,4)=MINTE
  306. INFCHE(ISOUS,5)=0
  307. IF(IMAGN.NE.0) THEN
  308. INFCHE(ISOUS,6)=2
  309. ENDIF
  310. *
  311. * RECHERCHE DES DIMENSIONS LES PLUS GRANDES
  312. *
  313. N1EL=0
  314. N1PTEL=0
  315. MPTVAL=IVADEP
  316. DO 178 IO=1,NDEP
  317. MELVAL=IVAL(IO)
  318. N1PTEL=MAX(N1PTEL,VELCHE(/1))
  319. N1EL =MAX(N1EL ,VELCHE(/2))
  320. 178 CONTINUE
  321. *
  322. IF (N1PTEL.EQ.1.OR.NBPGAU.EQ.1) THEN
  323. N1PTEL=1
  324. ELSE
  325. N1PTEL=NBPGAU
  326. ENDIF
  327. N1EL =MIN(N1EL ,NBELEM)
  328. *
  329. * CREATION DES MELVAL DU COURANT
  330. *
  331. NS=1
  332. NCOSOU=NGRA
  333. SEGINI MPTVAL
  334. IVAGRA=MPTVAL
  335. NOMID=MOGRAD
  336. SEGACT NOMID
  337. DO 77 IGR=1,NGRA
  338. TYPCHE(IGR)='REAL*8'
  339. NOMCHE(IGR)=LESOBL(IGR)
  340. N2PTEL=0
  341. N2EL=0
  342. SEGINI MELVAL
  343. IELVAL(IGR)=MELVAL
  344. IVAL(IGR)=MELVAL
  345. 77 CONTINUE
  346. SEGDES NOMID
  347. *
  348. IMESS = 0
  349. NBBB=NBNO
  350. IF (MFR.EQ.29) THEN
  351. NDUM=NGRA
  352. NGRA=NDUM*NBBB
  353. SEGINI MWRK1
  354. NGRA=NDUM
  355. ELSE
  356. SEGINI MWRK1
  357. ENDIF
  358. *
  359. * Boucle sur les {l{ments
  360. *
  361. DO 100 IB=1,NBELEM
  362. *
  363. * On cherche les coordonn{es des noeuds de l'{l{ment IB
  364. *
  365. CALL DOXE(XCOOR,IDIM,NBNO,NUM,IB,XE)
  366. *
  367. * On cherche les d{placements ou les temp{ratures
  368. *
  369. IE=1
  370. MPTVAL=IVADEP
  371. NDDD=NDEP
  372. IF (IFOUR.EQ.-3.AND.ITHER.EQ.0) NDDD=NDEP-3
  373. DO 200 IGAU=1,NBNN
  374. DO 200 ICOMP=1,NDDD
  375. MELVAL=IVAL(ICOMP)
  376. IF (MELVAL.NE.0) THEN
  377. IGMN=MIN(IGAU,VELCHE(/1))
  378. IBMN=MIN(IB ,VELCHE(/2))
  379. XDDL(IE)=VELCHE(IGMN,IBMN)
  380. ELSE
  381. XDDL(IE)=0.
  382. ENDIF
  383. IE=IE+1
  384. 200 CONTINUE
  385. *
  386. * On se dirige vers la zone sp{cifique selon l'{l{ment
  387. *
  388. GOTO (99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  389. & 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  390. & 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  391. & 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  392. & 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  393. & 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  394. & 99,99,99,99,99,99,99,27),MELE
  395. *
  396. 99 CONTINUE
  397. MOTERR(1:4)=NOMTP(MELE)
  398. MOTERR(9:12)='COURANT'
  399. IMESS = 86
  400. GOTO 9990
  401. *____________________________________________________________________*
  402. * 2/ COQ3 *
  403. *____________________________________________________________________*
  404. 27 CONTINUE
  405. IF(IMAGN.NE.0)THEN
  406. C COQUE MAGNETODYNAMIQUE
  407. CALL COQLOC(NBNN,XE,COSD1,COSD2,XE1)
  408. CALL ELGAUS(MINTE,MMAT1,SGAUSS,IFOIS,IFOI2)
  409. C
  410. IF(IFOIS.NE.0.AND.IFOIS.NE.NBPGAU)THEN
  411. *
  412. * LE JACOBIEN EST NEGATIF ,MAILLAGE INCORRECT
  413. INTERR(1)=IB
  414. CALL ERREUR(195)
  415. GO TO 9990
  416. ELSEIF(IFOI2.EQ.NBPGAU)THEN
  417. *
  418. * CAS OU LE JACOBIEN EST TRES PETIT
  419. *
  420. INTERR(1)=IB
  421. CALL ERREUR (259)
  422. GO TO 9990
  423. ENDIF
  424. DO 5027 IGAU=1,NBPGAU
  425. C
  426. C REMPLISSAGE
  427. C
  428. MPTVAL=IVAGRA
  429. DO 7027 IC=1,NGRA
  430. MELVAL=IVAL(IC)
  431. IBMN=MIN(IB ,VELCHE(/2))
  432. IGMN=MIN(IGAU,VELCHE(/1))
  433. DO 7027 IN=1,NBNN
  434. VELCHE(IGMN,IBMN)=VELCHE(IGMN,IBMN)+
  435. & GRAD(IC,IN,IGAU)*XDDL(IN)
  436. 7027 CONTINUE
  437. 5027 CONTINUE
  438. *
  439. ENDIF
  440. *
  441. 100 CONTINUE
  442. *
  443. * D{sactivation des segments
  444. *
  445. IF (MWRK1.NE.0) SEGSUP,MWRK1
  446. *
  447. CALL DTMVAL(IVADEP,1)
  448. CALL DTMVAL(IVACAR,1)
  449. CALL DTMVAL(IVAMAT,1)
  450. CALL DTMVAL(IVAGRA,1)
  451. *
  452. IF (ITHER.NE.0) THEN
  453. NOMID=MOTEMP
  454. SEGSUP NOMID
  455. ELSE IF(IMAGN.NE.0) THEN
  456. NOMID=MOFC
  457. SEGSUP NOMID
  458. ELSE
  459. NOMID=MODEPL
  460. SEGSUP NOMID
  461. ENDIF
  462. IF (MOCARA.NE.0) THEN
  463. NOMID=MOCARA
  464. SEGSUP NOMID
  465. ENDIF
  466. IF (MOMATR.NE.0) THEN
  467. NOMID=MOMATR
  468. SEGSUP NOMID
  469. ENDIF
  470. NOMID=MOGRAD
  471. if(lsupgd)SEGSUP NOMID
  472. *
  473. * IF(ITHER.EQ.0) SEGSUP INFO
  474. SEGDES,IMODEL,MELEME
  475. SEGDES,MCHAML,MINTE
  476. *
  477. 500 CONTINUE
  478. SEGDES,MMODEL,MCHELM
  479. * CALL DTCHAM(IPCHE2)
  480. *
  481. RETURN
  482. *
  483. 9990 CONTINUE
  484. *
  485. * ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  486. *
  487. IRET=0
  488. *
  489. * Gestion des messages d'erreur
  490. *
  491. IF (IMESS.NE.0) THEN
  492. INTERR(1) = IB
  493. CALL ERREUR(IMESS)
  494. ENDIF
  495. *
  496. IF (MWRK1.NE.0) SEGSUP,MWRK1
  497. SEGSUP MMAT1
  498. SEGSUP SGAUSS
  499. *
  500. CALL DTMVAL(IVADEP,1)
  501. CALL DTMVAL(IVACAR,1)
  502. CALL DTMVAL(IVAMAT,1)
  503. CALL DTMVAL(IVAGRA,3)
  504. *
  505. IF (MODEPL.NE.0) THEN
  506. NOMID=MODEPL
  507. SEGSUP NOMID
  508. ENDIF
  509. IF (MOTEMP.NE.0) THEN
  510. NOMID=MOTEMP
  511. SEGSUP NOMID
  512. ENDIF
  513. IF (MOCARA.NE.0)THEN
  514. NOMID=MOCARA
  515. SEGSUP NOMID
  516. ENDIF
  517. IF (lsupgd.and.MOGRAD.NE.0)THEN
  518. NOMID=MOGRAD
  519. SEGSUP NOMID
  520. ENDIF
  521. IF(MOMATR.NE.0)THEN
  522. NOMID=MOMATR
  523. SEGSUP NOMID
  524. ENDIF
  525. *
  526. SEGDES MELEME
  527. SEGDES IMODEL
  528. *
  529. SEGDES MMODEL
  530. IF (IPCHE1.NE.0) THEN
  531. MCHELM=IPCHE1
  532. SEGDES MCHELM
  533. ENDIF
  534. SEGSUP,MCHAML
  535. SEGSUP,MCHELM
  536. *
  537. * IF (IPCHE2.NE.0) CALL DTCHAM(IPCHE2)
  538. SEGDES MINTE
  539. * IF(ITHER.EQ.0) SEGSUP INFO
  540. RETURN
  541. END
  542.  
  543.  
  544.  
  545.  
  546.  
  547.  
  548.  
  549.  
  550.  
  551.  
  552.  
  553.  
  554.  
  555.  
  556.  
  557.  
  558.  

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