Télécharger manuc7.eso

Retour à la liste

Numérotation des lignes :

  1. C MANUC7 SOURCE CB215821 17/11/30 21:16:46 9640
  2.  
  3. *------------------------------------------------------------------
  4. *
  5. * CREATION D'UN MCHAML
  6. *
  7. *------------------------------------------------------------------
  8. *
  9. * PARAMETRES: (E)=ENTREE (S)=SORTIE
  10. * -----------
  11. *
  12. * IPMODL (E) POINTEUR DE L'OBJET MODELE
  13. * MODELE et SOUS-MODELE(S) ACTIFS EN ENTREE/SORTIE
  14. * MLMOTS (E) POINTEUR SUR UN LISTMOTS CONTENANT LES NOMS
  15. * ACTIF EN ENTREE/SORTIE
  16. * IPOI (E) POINTEUR SUR UN LISTENTI OU UN LISTREEL
  17. * MONMOT (E) MOT DE 8 CARACTERES
  18. * MLMOT3 (E) POINTEUR SUR UN LISTMOTS CONTENANT LES TYPES
  19. * MLMOT2 (E) POINTEUR SUR UN LISTMOTS CONTENANT LES TYPES
  20. * DES CONSTITUANTS
  21. * LETYP (E) TYPE DU MCHAML A CREER
  22. * JER1 (E) LONGUEUR DE LA CHAINE DE CARACTERES
  23. * ISUP1 (E) SUPPORT DEMANDE
  24. * ICHA (S) POINTEUR SUR LE MCHAML RESULTAT
  25. *
  26. * LANGAGE:
  27. * --------
  28. *
  29. * ESOPE + FORTRAN77
  30. *
  31. ************************************************************************
  32.  
  33. SUBROUTINE MANUC7(IPMODL,MLMOTS,IPOI,MONMOT,MLMOT3,MLMOT2,
  34. & LETYP,JER1,ISUP1,ICHA,itart)
  35.  
  36. IMPLICIT INTEGER(I-N)
  37. IMPLICIT REAL*8(A-H,O-Z)
  38.  
  39. -INC CCOPTIO
  40. -INC CCGEOME
  41.  
  42. -INC SMCHAML
  43. -INC SMELEME
  44. -INC SMLMOTS
  45. -INC SMLREEL
  46. -INC SMLENTI
  47. -INC SMMODEL
  48. -INC SMINTE
  49.  
  50. SEGMENT MPTVAL
  51. INTEGER IPOS(NS) ,NSOF(NS)
  52. INTEGER IVAL(NCOSOU)
  53. CHARACTER*16 TYVAL(NCOSOU)
  54. ENDSEGMENT
  55.  
  56. SEGMENT NOTYPE
  57. CHARACTER*16 TYPE(NBTYPE)
  58. ENDSEGMENT
  59.  
  60. SEGMENT INFO
  61. INTEGER INFELL(JG)
  62. ENDSEGMENT
  63. *
  64. PARAMETER ( N3 = 6 , NINF = 3 )
  65.  
  66. CHARACTER*(*) MONMOT, LETYP
  67.  
  68. CHARACTER*8 CHARIN
  69. CHARACTER*(NCONCH) CONM
  70. CHARACTER*4 CAR,CAR2
  71.  
  72. DIMENSION INFOS(NINF)
  73.  
  74. ICHA = 0
  75. ITHER= 0
  76. IDIFF= 0
  77. *
  78. MMODEL = IPMODL
  79. ** SEGACT,MMODEL <- Actif en E/S
  80. NSOUS = mmodel.KMODEL(/1)
  81. *
  82. * Determination du nombre de sous-modeles (sous-zones) a traiter :
  83. NSZ1 = NSOUS
  84. DO i = 1, NSOUS
  85. IMODEL = mmodel.KMODEL(i)
  86. ** SEGACT,IMODEL*NOMOD <- Actif en E/S
  87. IF (imodel.NEFMOD.EQ.22) NSZ1 = NSZ1 - 1
  88. IF (imodel.NEFMOD.EQ.259) NSZ1 = NSZ1 - 1
  89. ENDDO
  90. *
  91. * INITIALISATION DU SEGMENT MCHELM
  92. *
  93. N1 = NSZ1
  94. L1 = JER1
  95. SEGINI,MCHELM
  96. mchelm.TITCHE = LETYP
  97. mchelm.IFOCHE = IFOUR
  98. *
  99. ** SEGACT,MLMOTS <- Actif en E/S
  100. N2 = mlmots.MOTS(/2)
  101.  
  102. SEGACT,MLMOT3,MLMOT2
  103. IF (MONMOT.EQ.'REAL*8 ') THEN
  104. MLREEL = IPOI
  105. SEGACT,MLREEL
  106. ELSE
  107. MLENTI = IPOI
  108. SEGACT,MLENTI
  109. ENDIF
  110.  
  111. INFOS(1) = 0
  112. INFOS(2) = 0
  113. INFOS(3) = NIFOUR
  114. *
  115. * BOUCLE SUR LES ZONES ELEMENTAIRES DU MODELE
  116. *
  117. kch = 0
  118. DO 20 isous = 1, NSOUS
  119. *
  120. IMODEL = mmodel.KMODEL(isous)
  121. C
  122. C ON RECUPERE L INFORMATION GENERALE
  123. C
  124. IPMAIL = imodel.IMAMOD
  125. CONM = imodel.CONMOD
  126. C____________________________________________________________________
  127. C
  128. C INFORMATION SUR L'ELEMENT FINI
  129. C____________________________________________________________________
  130. C
  131. MELE = imodel.NEFMOD
  132. IF (MELE.EQ.22) GOTO 20
  133. IF (MELE.EQ.259) GOTO 20
  134. *
  135. NFOR = imodel.FORMOD(/2)
  136. CALL PLACE(imodel.FORMOD,NFOR,ITHER,'THERMIQUE')
  137. CALL PLACE(imodel.FORMOD,NFOR,IDIFF,'DIFFUSION')
  138. CALL PLACE(imodel.FORMOD,NFOR,ICONT,'CONTACT')
  139. CALL PLACE(imodel.FORMOD,NFOR,IDARC,'DARCY')
  140. C
  141. C CAS DE LA FORMULATION DARCY ON VA EXTRAIRE LE MAILLAGE SOMMET
  142. C
  143. IF (IDARC.NE.0)THEN
  144. CALL LEKMOD(MMODEL,IPTABL,INEFMD)
  145. CHARIN = 'MAILLAGE'
  146. CALL LEKTAB(IPTABL,CHARIN, IOBRE)
  147. IF (IERR.NE.0) RETURN
  148. C* Inutile de reactiver le modele suite a LEKMOD :
  149. IPT1 = IOBRE
  150. IPMAIL= IOBRE
  151. c??? IF (NSZ1.GT.1) THEN
  152. IF (NSOUS.GT.1) THEN
  153. SEGACT IPT1
  154. IPMAIL = IPT1.LISOUS(isous)
  155. C SEGDES IPT1
  156. ENDIF
  157. ENDIF
  158. C Fin du cas special DARCY
  159. *
  160. IPPORE = 0
  161. IF (MELE.GE.79.AND.MELE.LE.83) IPORE = NBNNE(NUMGEO(MELE))
  162.  
  163. ISUP = ISUP1
  164. *
  165. * EN CAS DE FORMULATION CONTACT, SEUL SUPPORT = LES NOEUDS
  166. * AM 25/1/08 ON FORCE LE SUPPORT EN CONSEQUENCE AU LIEU DE SORTIR EN ERREUR
  167. IF (ICONT.NE.0 .AND. ISUP.NE.1) ISUP = 1
  168. *
  169. IPMIN = 0
  170. MFR = 0
  171. info = 0
  172. IF (ISUP.NE.1) THEN
  173. IF (ITHER.EQ.0 .AND. IDIFF.EQ.0) THEN
  174. IF (2+ISUP.GT.infmod(/1)) THEN
  175. CALL ELQUOI(MELE,0,ISUP,IPINF,IMODEL)
  176. IF (IERR.NE.0) GOTO 99
  177. info = IPINF
  178. IPMIN = info.INFELL(11)
  179. MFR = info.INFELL(13)
  180. SEGSUP,info
  181. else
  182. IPMIN = infmod(ISUP+2)
  183. MFR = INFELE(13)
  184. endif
  185. ELSE
  186. c en thermique, on veut les points de gauss ad hoc
  187. ISUP = 6
  188. iplr = 0
  189. iplc = 0
  190. nmat = imodel.matmod(/2)
  191. CALL PLACE(imodel.matmod,nmat,iplr,'RAYONNEMENT')
  192. CALL PLACE(imodel.matmod,nmat,iplc,'CONVECTION')
  193. IF (iplr+iplc.eq.0) THEN
  194. CALL TSHAPE(MELE,'GAUSS',IPMIN)
  195. ELSE
  196. NLG = NUMGEO(MELE)
  197. CALL TSHAPE(NLG,'GAUSS',IPMIN)
  198. ENDIF
  199. ENDIF
  200. ENDIF
  201. MINTE = IPMIN
  202. IF (IPMIN.NE.0) SEGACT,MINTE
  203.  
  204. kch = kch+1
  205. IMACHE(kch) = IPMAIL
  206. CONCHE(kch) = CONMOD
  207. INFCHE(kch,1) = 0
  208. INFCHE(kch,2) = 0
  209. INFCHE(kch,3) = NIFOUR
  210. INFCHE(kch,4) = IPMIN
  211. INFCHE(kch,5) = 0
  212. INFCHE(kch,6) = ISUP
  213.  
  214. SEGINI,MCHAML
  215. ICHAML(kch) = MCHAML
  216. *
  217. N1PTEL = 0
  218. N1EL = 0
  219. N2PTEL = 0
  220. N2EL = 0
  221.  
  222. IF (MONMOT.EQ.'REAL*8 ') THEN
  223. N1PTEL = 1
  224. N1EL = 1
  225. DO in = 1, N2
  226. SEGINI,MELVAL
  227. melval.VELCHE(N1PTEL,N1EL) = mlreel.PROG(in)
  228. SEGDES,MELVAL
  229. mchaml.NOMCHE(in) = mlmots.MOTS(in)
  230. mchaml.TYPCHE(in) = MONMOT(1:6)
  231. mchaml.IELVAL(in) = MELVAL
  232. ENDDO
  233.  
  234. ELSE
  235.  
  236. DO 10 in = 1, N2
  237. mchaml.NOMCHE(in) = mlmots.MOTS(in)
  238. CAR = MLMOT3.MOTS(in)(1:4)
  239. CAR2 = MLMOT2.MOTS(in)(1:4)
  240. *
  241. * TRAITEMENT PARTICULIER POUR LE TYPE 'MCHAML'
  242. *---------------
  243. IF (CAR.EQ.'MCHA') THEN
  244. *
  245. * MODIF 02/94 POUR POUTRE A FIBRES
  246. * TEST SUR LES MAILLAGES POINTES
  247. *
  248. IPCHE1 = mlenti.LECT(in)
  249. MCHEL1 = IPCHE1
  250. SEGACT,MCHEL1
  251. NSOU1 = MCHEL1.ICHAML(/1)
  252. IDEM = 0
  253. DO 294 i = 1, NSOU1
  254. IF (IPMAIL.EQ.MCHEL1.IMACHE(i)) IDEM = 1
  255. 294 CONTINUE
  256. SEGDES,MCHEL1
  257. IF (IDEM.EQ.0) GO TO 295
  258. *
  259. CALL QUESUP(IPMODL,IPCHE1,ISUP,0,IRET1,IRET2)
  260. IF (IRET1.GT.1) THEN
  261. SEGSUP MCHAML
  262. GOTO 99
  263. ENDIF
  264. * On reactive le modele suite a APPEL a QUESUP !
  265. MMODEL = IPMODL
  266. SEGACT,MMODEL
  267. DO i = 1, NSOUS
  268. imode1 = mmodel.KMODEL(i)
  269. SEGACT,imode1
  270. ENDDO
  271.  
  272. NBROBL = 1
  273. NBRFAC = 0
  274. SEGINI NOMID
  275. MOTAUX = NOMID
  276. LESOBL(1)= mchaml.NOMCHE(in)
  277. NBTYPE = 1
  278. SEGINI,NOTYPE
  279. MOTYPE = NOTYPE
  280. TYPE(1) = ' '
  281. CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOTAUX,MOTYPE,
  282. $ 2,INFOS,3,IVAAUX)
  283. SEGSUP,NOTYPE
  284. IF (IERR.NE.0)THEN
  285. SEGSUP MCHAML
  286. GOTO 99
  287. ENDIF
  288. IF (IRET1.EQ.1) THEN
  289. CALL VALCHE(IVAAUX,1,IPMIN,IPPORE,MOTAUX,MELE)
  290. IF (IERR.NE.0) THEN
  291. MPTVAL = IVAAUX
  292. MELVA1 = IVAL(1)
  293. SEGDES MELVA1
  294. SEGSUP MPTVAL
  295. SEGSUP MCHAML
  296. GOTO 99
  297. ENDIF
  298. ENDIF
  299. SEGSUP,NOMID
  300. MPTVAL = IVAAUX
  301. mchaml.TYPCHE(in) = TYVAL(1)
  302. MELVA1 = IVAL(1)
  303. SEGINI,MELVAL=MELVA1
  304. IELVAL(IN) = MELVAL
  305. IF (IRET1.EQ.1)THEN
  306. SEGSUP MELVA1
  307. ELSE
  308. SEGDES,MELVA1
  309. ENDIF
  310. SEGSUP,MPTVAL
  311. SEGDES,MELVAL
  312. GOTO 10
  313. 295 CONTINUE
  314. ENDIF
  315. *
  316. IF (itart.EQ.1 .AND. CAR.EQ.'LIST'
  317. $ .AND. CAR2.EQ.'REEL') THEN
  318. mchaml.TYPCHE(IN) = 'REAL*8 '
  319. ipt4 = ipmail
  320. segact,ipt4
  321. N1EL = ipt4.num(/2)
  322. segdes,ipt4
  323. N1PTEL = 1
  324. N2PTEL = 0
  325. N2EL = 0
  326. SEGINI,MELVAL
  327. mlree2 = mlenti.lect(in)
  328. segact,mlree2
  329. jg2 = mlree2.prog(/1)
  330. ia = 0
  331. do i = 1, n1el
  332. ia = ia+1
  333. IF (ia.GT.jg2) ia=1
  334. melval.velche(N1PTEL,i) = mlree2.prog(ia)
  335. enddo
  336. segdes mlree2
  337. ELSE
  338. mchaml.TYPCHE(IN) = 'POINTEUR'//car//car2
  339. N1PTEL = 0
  340. N1EL = 0
  341. mlent2 = mlenti.lect(in)
  342. if (ITART.EQ.1.AND.car2(1:4).eq.'INT ') then
  343. ipt4 = ipmail
  344. SEGACT,ipt4
  345. N2EL = ipt4.num(/2)
  346. SEGDES,ipt4
  347. N2PTEL = 1
  348. SEGINI,MELVAL
  349. segact,mlent2
  350. jg2 = mlent2.lect(/1)
  351. ia = 0
  352. do i = 1, n2el
  353. ia = ia+1
  354. IF (ia.GT.jg2) ia=1
  355. melval.ielche(N2PTEL,i) = mlent2.lect(ia)
  356. enddo
  357. segdes,mlent2
  358. else
  359. N2PTEL = 1
  360. N2EL = 1
  361. SEGINI,MELVAL
  362. melval.ielche(1,1) = mlent2
  363. endif
  364. ENDIF
  365. SEGDES,MELVAL
  366. mchaml.IELVAL(IN) = MELVAL
  367.  
  368. 10 CONTINUE
  369. * ENDDO
  370. *
  371. ENDIF
  372. *
  373. IF (IPMIN.NE.0) SEGDES,MINTE
  374. SEGDES,MCHAML
  375.  
  376. 20 CONTINUE
  377. * ENDDO
  378.  
  379. 99 CONTINUE
  380. IF (MONMOT.EQ.'REAL*8 ') THEN
  381. SEGDES,MLREEL
  382. ELSE
  383. SEGDES,MLENTI
  384. ENDIF
  385. SEGDES,MLMOT3,MLMOT2
  386. *
  387. IF (IERR.EQ.0)THEN
  388. SEGDES,MCHELM
  389. ELSE
  390. SEGSUP,MCHELM
  391. MCHELM = 0
  392. ENDIF
  393. ICHA = MCHELM
  394. *
  395. RETURN
  396. END
  397.  
  398.  
  399.  
  400.  
  401.  

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