Télécharger fuschl.eso

Retour à la liste

Numérotation des lignes :

  1. C FUSCHL SOURCE JC220346 12/03/13 21:15:06 7306
  2. SUBROUTINE FUSCHL(MCHEL1,MCHEL2,IRECHE)
  3. IMPLICIT REAL*8 (A-H,O-Z)
  4. ************************************************************************
  5. *
  6. * F U S C H L
  7. * -----------
  8. *
  9. * FONCTION:
  10. * ---------
  11. * REUNION DE DEUX OBJETS DE TYPE "CHAMELEM".
  12. *
  13. * MODULES UTILISES:
  14. * -----------------
  15. *
  16. IMPLICIT INTEGER(I-N)
  17. -INC CCOPTIO
  18. -INC SMCHAML
  19. *
  20. * PARAMETRES: (E)=ENTREE (S)=SORTIE (+ = CONTENU DANS UN COMMUN)
  21. * -----------
  22. *
  23. * MCHEL1 (E) POINTEUR SUR LE PREMIER "CHAMELEM"
  24. * MCHEL2 (E) POINTEUR SUR LE DEUXIEME "CHAMELEM"
  25. * IRECHE (S) POINTEUR SUR LE "CHAMELEM" RESULTAT
  26. * ( =0 SI ECHEC )
  27. *
  28. * VARIABLES:
  29. * ----------
  30. *
  31. * SOUTYP = SOUS-TYPE DU "CHAMELEM" RESULTAT.
  32. * LSOUTY = LONGUEUR UTILE DE LA CHAINE "SOUTYP"
  33.  
  34. segment traa
  35. integer ncompi(ncomp),n2r(n1)
  36. endsegment
  37. CHARACTER*8 NOP
  38. CHARACTER*16 CON
  39. INTEGER LSOUTY
  40. CHARACTER*72 SOUTYP
  41. *
  42. * REMARQUES:
  43. * ----------
  44. *
  45. *
  46. * - DANS LE CAS DE LA REUNION DE 2 "CHAMELEM" DE SOUS-TYPES
  47. * DIFFERENTS, LE SOUS-TYPE DU RESULTAT EST:
  48. * . LE SOUS-TYPE DE L'UN SI LE SOUS-TYPE DE L'AUTRE EST ' '
  49. * . ' ' DANS LES AUTRES CAS.
  50. *
  51. * - DANS LE CAS OU UNE COMPOSANTE EST COMMUNE SUR UNE ZONE
  52. * ELEMENTAIRE COMMUNE, ON verifie QUE SES VALEURS SONT LES MEMES
  53. * DANS LES DEUX "CHAMELEM" INITIAUX (nature diffuse par defaut)
  54. *
  55. * AUTEUR, DATE DE CREATION:
  56. * -------------------------
  57. *
  58. * DENIS ROBERT, LE 21 DECEMBRE 1987. - MODIF BRUN.J (MAI 90)
  59. *
  60. * LANGAGE:
  61. * --------
  62. *
  63. * ESOPE + FORTRAN77
  64. *
  65. ************************************************************************
  66. *
  67. * SOUS-TYPES DE NOS "CHAMELEM"
  68. *
  69. ireche=0
  70. SEGACT,MCHEL1
  71. SEGACT,MCHEL2
  72. *
  73. SOUTYP = MCHEL1.TITCHE
  74. LSOUTY = MCHEL1.TITCHE(/1)
  75. *
  76. IF (SOUTYP .EQ. ' ') THEN
  77. IF (MCHEL2.TITCHE .NE. ' ') THEN
  78. SOUTYP = MCHEL2.TITCHE
  79. LSOUTY = MCHEL2.TITCHE(/1)
  80. ENDIF
  81. ELSE
  82. IF (MCHEL2.TITCHE .NE. SOUTYP) THEN
  83. IF (MCHEL2.TITCHE .NE. ' ') THEN
  84. SOUTYP=' '
  85. LSOUTY=1
  86. ENDIF
  87. ENDIF
  88.  
  89. ENDIF
  90. *
  91. LSOUTY = MAX(LSOUTY,1)
  92. *
  93. * NOMBRE DE ZONES DE CHAQUE "CHAMELEM"
  94. *
  95. NSOU1=MCHEL1.IMACHE(/1)
  96. NSOU2=MCHEL2.IMACHE(/1)
  97. N31=MCHEL1.INFCHE(/2)
  98. N32=MCHEL2.INFCHE(/2)
  99.  
  100. *+*
  101. N33=MIN(N31,N32)
  102. N3=MAX(N31,N32)
  103. * on active tout
  104. ncomp=0
  105. DO 5 ISOUS=1,NSOU1
  106. MCHAML=MCHEL1.ICHAML(ISOUS)
  107. SEGACT,MCHAML
  108. ncomp=max(ncomp,ielval(/1))
  109. 5 CONTINUE
  110. DO 6 ISOUS=1,NSOU2
  111. MCHAML=MCHEL2.ICHAML(ISOUS)
  112. SEGACT,MCHAML
  113. ncomp=max(ncomp,ielval(/1))
  114. 6 continue
  115. * on cree le résultat
  116. n1=nsou1+nsou2
  117. segini traa
  118. itrf=1
  119. l1=lsouty
  120. segini mchelm
  121. titche=soutyp
  122. ifoche=ifour
  123.  
  124. * JCARDO 13/03/2012 : gestion du cas où au moins un des MCHAML est vide
  125. if (n1.eq.0) goto 66
  126. if (nsou1.eq.0) then
  127. mchel3=mchel2
  128. n33=n32
  129. else
  130. mchel3=mchel1
  131. n33=n31
  132. endif
  133.  
  134. * on commence par recopier le premier sous champ
  135. conche(1)=mchel3.conche(1)
  136. imache(1)=mchel3.imache(1)
  137. mcham2=mchel3.ichaml(1)
  138. segini,mchaml=mcham2
  139. ichaml(1)=mchaml
  140. n2r(1)=ielval(/1)
  141. do k=1,n33
  142. infche(1,k)=mchel3.infche(1,k)
  143. enddo
  144. n1=1
  145. * on reprend tous les autres sous champs et on se pose la question de
  146. * savoir si meme imache,meme nophas, meme conche,
  147. * si oui on additionnera directement dans le mchaml apres
  148. * avoir testé si meme nom de composante , meme support (infche(6)
  149. * meme typche , meme valeur
  150.  
  151.  
  152. ipas=0
  153. 7 continue
  154. if(ipas.eq.0) then
  155. mchel3=mchel1
  156. nsous=nsou1
  157. n33=n31
  158. else
  159. mchel3=mchel2
  160. nsous=nsou2
  161. n33=n32
  162. endif
  163. do 8 i=1,nsous
  164. if( i.eq.1.and.ipas.eq.0) go to 8
  165. ima=mchel3.imache(i)
  166. inf3=mchel3.infche(i,3)
  167. inf6=mchel3.infche(i,6)
  168. nop=mchel3.conche(i)(17:24)
  169. con=mchel3.conche(i)
  170. mcham3=mchel3.ichaml(i)
  171. ncomp=mcham3.ielval(/1)
  172. if (itrf.eq.0) then
  173. do k=1,ncomp
  174. ncompi(k)=0
  175. enddo
  176. endif
  177. itrf=0
  178. do 9 j=1,n1
  179. if( ima.ne.imache(j)) go to 9
  180. if( con.ne.conche(j)) go to 9
  181. if( nop.ne.conche(j)(17:24)) go to 9
  182.  
  183. * on en a trouvé une zone identique on continue par tester les noms
  184. * de composantes
  185. mchaml=ichaml(j)
  186. * write(6,*) ' prise de mchaml j ' , mchaml,j
  187. do 10 kold=1,mcham3.ielval(/1)
  188. do 11 knew=1,n2r(j)
  189. if(mcham3.nomche(kold).eq.nomche(knew))then
  190. * on teste meme support
  191. if( inf6.ne.infche(j,6)) then
  192. moterr(1:4)=nomche(knew)
  193. call erreur(1010)
  194. return
  195. endif
  196. * on teste meme typche
  197. if(mcham3.typche(kold).ne.typche(knew)) then
  198. moterr(1:4) = mcham3.nomche(kold)
  199. moterr(5:21) = mcham3.typche(kold)
  200. moterr(22:38) = typche(knew)
  201. segdes mcham3, mchaml
  202. *le type %m5:21 et le type %m22:38 sont incompatibles pour la composante %m1:4
  203. call erreur(917)
  204. return
  205. endif
  206. * on teste les valeurs
  207. * regarde les melval
  208. melva1 = mcham3.ielval(kold)
  209. melva2 = ielval(knew)
  210. segact melva1,melva2
  211. if (mcham3.typche(kold).eq.'REAL*8') then
  212. n1ptel = melva1.velche(/1)
  213. n1el = melva1.velche(/2)
  214. m1ptel = melva2.velche(/1)
  215. m1el = melva2.velche(/2)
  216. l11 = max(n1ptel,m1ptel)
  217. l2 = max(n1el,m1el)
  218. do jptel =1,l11
  219. do jel =1,l2
  220. x1 = melva1.velche(min(jptel,n1ptel),min(jel,n1el))
  221. x2 = melva2.velche(min(jptel,m1ptel),min(jel,m1el))
  222. if(abs(x1-x2).gt.(abs(x1+x2))/2.*1.d-6) then
  223. interr(1)=jptel
  224. interr(2)=jel
  225. moterr(1:4) = mcham3.nomche(kold)
  226. * composante %m1:4 : les valeurs ne sont pas identiques au point d integration
  227. * (%i1,%i2)
  228. segdes melva1, melva2
  229. call erreur(918)
  230. return
  231. endif
  232. enddo
  233. enddo
  234. else
  235. * pointeurs
  236. n2ptel=melva1.ielche(/1)
  237. n2el=melva1.ielche(/2)
  238. m2ptel=melva2.ielche(/1)
  239. m2el=melva2.ielche(/2)
  240. l11 = max(n2ptel,m2ptel)
  241. l2 = max(n2el,m2el)
  242. do jptel =1,l11
  243. do jel =1,l2
  244. x1 = melva1.ielche(min(jptel,n2ptel),min(jel,n2el))
  245. x2 = melva2.ielche(min(jptel,m2ptel),min(jel,m2el))
  246. if(abs(x1-x2).gt.(abs(x1+x2))/2.*1.d-6) then
  247. interr(1)=jptel
  248. interr(2)=jel
  249. moterr(1:4) = mcham3.nomche(kold)
  250. segdes melva1, melva2
  251. call erreur(918)
  252. return
  253. endif
  254. enddo
  255. enddo
  256. endif
  257. segdes melva1,melva2
  258. ncompi(kold)=1
  259. * tout est bon : meme support , meme typche, meme valeurs--> rien à faire
  260. go to 10
  261. endif
  262. 11 continue
  263. * ici lon n'a pas trouvé de composantes identiques on regarde si
  264. * meme infche(6, si oui on agrandi mchaml pour ajouterer la composante
  265. * sinon on continue pour tester les autres parties du nouveau champ
  266. if(inf6.eq.infche(j,6)) then
  267. * write(6,*) ' on passe ici mchaml ', mchaml
  268. n2r(j)=n2r(j)+1
  269. if (n2r(j).gt.ielval(/1)) then
  270. n2=n2r(j)+10
  271. segadj mchaml
  272. endif
  273. n2=n2r(j)
  274. * write(6,*) ' succés'
  275. nomche(n2)=mcham3.nomche(kold)
  276. ielval(n2)=mcham3.ielval(kold)
  277. typche(n2)=mcham3.typche(kold)
  278. ncompi(kold)=1
  279. go to 10
  280. endif
  281. 10 continue
  282. 9 continue
  283. * on a fini de regarder le nouveau champ et on a rangé là ou on pouvait
  284. * certaines composantes. on compte combien il y a encore de
  285. * composantes à ranger
  286. n2=0
  287. do k=1,ncomp
  288. if( ncompi(k).eq.0) then
  289. n2=n2+1
  290. endif
  291. enddo
  292. if(n2.ne.0) then
  293. n1=n1+1
  294. imache(n1)=ima
  295. conche(n1)=con
  296. conche(n1)(17:24)=nop
  297. do m=1,n33
  298. infche(n1,m)=mchel3.infche(i,m)
  299. enddo
  300. segini mchaml
  301. ichaml(n1)=mchaml
  302. n2r(n1)=n2
  303. ik=0
  304. do k=1,ncomp
  305. if(ncompi(k).eq.0) then
  306. ik=ik+1
  307. nomche(ik)=mcham3.nomche(k)
  308. ielval(ik)=mcham3.ielval(k)
  309. typche(ik)=mcham3.typche(k)
  310. endif
  311. enddo
  312. endif
  313. 8 continue
  314. ipas=ipas+1
  315. if(ipas.le.1) go to 7
  316. *
  317. * on a fini
  318. *
  319. DO ISOUS=1,NSOU1
  320. MCHAML=MCHEL1.ICHAML(ISOUS)
  321. * do iup=1,ielval(/1)
  322. * melva1=ielval(iup)
  323. * segdes melva1
  324. * enddo
  325. *pv SEGDES MCHAML
  326. ENDDO
  327. DO ISOUS=1,NSOU2
  328. MCHAML=MCHEL2.ICHAML(ISOUS)
  329. * do iup=1,ielval(/1)
  330. * melva1=ielval(iup)
  331. * segdes melva1
  332. * enddo
  333. *pv SEGDES,MCHAML
  334. ENDDO
  335. *pv segdes,mchel1,mchel2
  336. if(n1.ne.imache(/1)) segadj mchelm
  337. * call zpchel(mchelm,1)
  338. do i=1,ichaml(/1)
  339. mchaml=ichaml(i)
  340. n2=n2r(i)
  341. if (n2.ne.ielval(/1)) segadj mchaml
  342. * do iup=1,ielval(/1)
  343. * melva1=ielval(iup)
  344. * segdes melva1
  345. * enddo
  346. segdes mchaml
  347. enddo
  348. 66 segsup traa
  349. segdes mchelm
  350.  
  351. ireche=mchelm
  352. * write(6,*) ' resultat de fuschl mchelm' , ireche
  353. return
  354. end
  355.  
  356.  
  357.  
  358.  
  359.  

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