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

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