Télécharger la plaquette Cast3M


fr en

Télécharger fuschl.eso

Retour à la liste

Numérotation des lignes : 

fuschl

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

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