Sources Esope | Cast3M

nuachl
C NUACHL    SOURCE    CB215821  20/11/04    21:19:24     10766          
       SUBROUTINE NUACHL(ICHML)
*
*   sous-routine de l'operateur nuage pour créer un objet nuage
*   à partir d'un champ par élément à composantes réelles.
*
      IMPLICIT INTEGER(I-N)
       IMPLICIT REAL*8(A-H,O-Z)
*
 
-INC PPARAM
-INC CCOPTIO
-INC SMNUAGE
-INC SMCHAML
-INC SMELEME
*
*  création d'un segment pour pouvoir créer un tableau
*
       SEGMENT,ITABLE
         CHARACTER*(LOCOMP) COMPOS(N)
         INTEGER TABLEA(N1,N)
C          compos(i)   : nom de la i-ème composante
C          tablea(j,k) : place de la k-ème composante dans le j-ème segment
       ENDSEGMENT
 
       IRETOU = 0
*
*  lecture du mchaml
*
       MCHELM = ICHML
       SEGACT MCHELM
       N1 = ICHAML(/1)
*
*  création du tableau
*
       IF (N1.EQ.0) THEN
          NVAR = 0
          NCOUP = 0
          SEGINI MNUAGE
          SEGDES MNUAGE
       ENDIF
*
       NBCOUP = 0
       DO 10 I = 1,N1
        MCHAML = ICHAML(I)
        SEGACT MCHAML
        N2 = NOMCHE(/2)
        DO 5 J = 1,N2
* affichage de l'erreur dans le cas où les composantes ne sont pas
* réelles
         IF (TYPCHE(J) .NE.'REAL*8') THEN
            MOTERR(1:8)=TYPCHE(J)
            MOTERR(17:20)=NOMCHE(J)
            MOTERR(21:29) = 'ARGUMENT'
            DO 7 K = 1,I
             MCHAML = ICHAML(K)
             SEGDES MCHAML
  7         CONTINUE
            SEGDES MCHELM
            CALL ERREUR(552)
            RETURN
         ENDIF
  5      CONTINUE
*
        MELEME = IMACHE(I)
        SEGACT MELEME
        NBCOUP = NBCOUP + NUM(/1)*NUM(/2)
        IF (I.EQ.1) THEN
           N = N2
           SEGINI ITABLE
           do 20 j =1,n2
            compos(j) = nomche(j)
            tablea(i,j) = j
   20      CONTINUE
        ELSE
           l = n
           do 40 k = 1,n2
            do 50 j = 1,n
             if (tablea(i,j).eq.0) then
                if (nomche(k).eq.compos(j)) then
                   tablea(i,j) = k
                   goto 40
                endif
             endif
   50       CONTINUE
            l = l+1
            n = l
            segadj itable
            compos(l) = nomche(k)
            tablea(i,l) = k
   40      CONTINUE
        ENDIF
        SEGDES MELEME
        SEGDES MCHAML
   10  CONTINUE
 
*
*  initialisation de l'objet nuage
*
       NVAR = N
       SEGINI MNUAGE
       DO 60 I =1,NVAR
        NUANOM(I) = COMPOS(I)
        NUATYP(I) = 'FLOTTANT'
        SEGINI NUAVFL
        NUAPOI(I)=NUAVFL
   60  CONTINUE
*
*  création du n-uplets du nuage
*
* le nuage ne contient que des flottants
* boucle sur les sous zones
       IND = 1
       DO  70 I = 1,N1
        MCHAML = ICHAML(I)
        SEGACT MCHAML
        MELEME = IMACHE(I)
        SEGACT MELEME
        nbnn = num(/1)
        nbelem = num(/2)
* boucle sur les éléments
        do 80 j = 1,nbelem
* boucle sur les points
         do 90 k = 1,nbnn
* remplissage du tableau pour chaque composante
          DO 100 L = 1,NVAR
           NUAVFL = NUAPOI(L)
           N3 = TABLEA(I,L)
           IF (N3.EQ.0) THEN
              NUAFLO(IND) = 0.D0
           ELSE
              MELVAL = IELVAL(N3)
              SEGACT MELVAL
              KMIN = MIN(VELCHE(/1),K)
              JMIN= MIN(J,VELCHE(/2))
              NUAFLO(IND) = VELCHE(KMIN,JMIN)
              SEGDES  MELVAL
           ENDIF
  100     CONTINUE
          IND = IND + 1
   90    CONTINUE
   80   CONTINUE
        SEGDES MELEME
        SEGDES MCHAML
   70  CONTINUE
       SEGSUP ITABLE
       SEGDES MCHELM
       DO 110 I=1,NVAR
          NUAVFL=NUAPOI(I)
          SEGDES NUAVFL
 110   CONTINUE
       SEGDES MNUAGE
*
*  ecriture du nuage
*
       CALL ECROBJ('NUAGE ',MNUAGE)
       END