Télécharger deco1.eso

Retour à la liste

Numérotation des lignes :

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

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