Télécharger fuschl.eso

Retour à la liste

Numérotation des lignes :

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

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