Télécharger manuc7.eso

Retour à la liste

Numérotation des lignes :

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

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