Télécharger manuc7.eso

Retour à la liste

Numérotation des lignes :

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

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