Sources Esope | Cast3M

dedu3
C DEDU3     SOURCE    CB215821  20/11/25    13:24:23     10792          
C
      SUBROUTINE DEDU3(IPCHPO,XERR1)
************************************************************************
*
*                                DEDU3
*
*
* FONCTION:
*    -appelé par PROPER.eso
*    -TESTE SI UN CHPOINT DE TRANSFORMATION U REPRESENTE UNE TRANSLATION
*    -calcule l'ecart relatif à une translation :
*       XERR1 = | max_x(IPOIN1(x)) - min_x(IPOIN1(x)) |_relatif
*
* CREATION,MODIFICATION:
*    - creation : 07/2009 (BP)
*
************************************************************************
*
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
-INC PPARAM
-INC CCOPTIO
-INC SMCHPOI
-INC SMELEME
-INC SMCOORD
*
*
***** INITIALISATIONS **************************************************
*
*    -ERREUR RELATIVE, LONGUEUR CARACTERISTIQUE
      XERR1 = 0.D0
      XREF1 = 0.D0
 
*    -ACTIVATION DU CHPOINT DE TRANSFORMATION
      MCHPOI = IPCHPO
      SEGACT,MCHPOI
      NSOUPO = IPCHP(/1)
*
*
***** RECHERCHE DU MAXIMUM par ZONE ************************************
 
*-----boucle sur les zones du chpoint
      DO 100 IB100=1,NSOUPO
*
*       -sous-chpoint
         MSOUPO = IPCHP(IB100)
         SEGACT,MSOUPO
 
*       -ouverture du mpoval
         NC = NOCOMP(/2)
         MPOVAL = IPOVAL
         SEGACT,MPOVAL
 
*       -creation de mpova1 contenant le maxi et le mini
         N  = 2
         segini,mpova1
         IDEB = 0
 
*       -ouverture du meleme pour avoir une distance de reference XREF100
         XREF100 = 0.D0
         IPT3 = IGEOC
         segact,IPT3
         N3 = IPT3.NUM(/2)
 
*--------boucle sur les points
         N = VPOCHA(/1)
*         write(6,*) 'N3=N?',N3,N
         if (N.gt.0) then
         DO 110 IB110=1,N
 
*----------1ere rencontre avec boucle sur les composantes
           IF(IDEB.eq.0) THEN
              IDEB = 1
*            -recup des coordonnées
              IP = IPT3.NUM(1,IB110)
              X1 = XCOOR((IP-1)*(IDIM+1)  +1)
              Y1 = XCOOR((IP-1)*(IDIM+1)  +2)
              XMAX1 = X1
              XMIN1 = X1
              YMAX1 = Y1
              YMIN1 = Y1
              if(IDIM.EQ.3)  then
                Z1 = XCOOR((IP-1)*(IDIM+1)  +3)
                ZMAX1 = Z1
                ZMIN1 = Z1
              endif
*            -boucle sur les composantes
              DO 120 IB120=1,NC
                XVAL = VPOCHA(IB110,IB120)
                mpova1.VPOCHA(1,IB120) = XVAL
                mpova1.VPOCHA(2,IB120) = XVAL
  120         CONTINUE
              goto 110
           ENDIF
 
*----------recup des coordonnées
           IP = IPT3.NUM(1,IB110)
           X1 = XCOOR((IP-1)*(IDIM+1)  +1)
           Y1 = XCOOR((IP-1)*(IDIM+1)  +2)
           if(X1.gt.XMAX1)   XMAX1 = X1
           if(X1.lt.XMIN1)   XMIN1 = X1
           if(Y1.gt.YMAX1)   YMAX1 = Y1
           if(Y1.lt.YMIN1)   YMIN1 = Y1
           if(IDIM.EQ.3)  then
             Z1 = XCOOR((IP-1)*(IDIM+1)  +3)
             if(Z1.gt.ZMAX1)  ZMAX1 = Z1
             if(Z1.lt.ZMIN1)  ZMIN1 = Z1
           endif
 
*----------boucle sur les composantes
           DO 121 IB120=1,NC
              XVAL = VPOCHA(IB110,IB120)
*            -tests
              if(XVAL.gt.(mpova1.VPOCHA(1,IB120)))
     $          mpova1.VPOCHA(1,IB120) = XVAL
              if(XVAL.lt.(mpova1.VPOCHA(2,IB120)))
     $          mpova1.VPOCHA(2,IB120) = XVAL
  121      CONTINUE
 
  110    CONTINUE
*--------fin de boucle sur les points
 
*--------calcul de XREF100
*         write(6,*) 'MAX=',XMAX1,YMAX1,ZMAX1
*         write(6,*) 'MIN=',XMIN1,YMIN1,ZMIN1
         XREF100 = (XMAX1 - XMIN1) + (YMAX1 - YMIN1) + (ZMAX1 - ZMIN1)
         XREF100 = XREF100 / N
*--------calcul de la norme XERR100 = |max(U_ib100) - min(U_ib100)|_1
         XERR100 = 0.D0
         DO 129 IB120=1,NC
           UMAX1 = mpova1.VPOCHA(1,IB120)
           UMIN1 = mpova1.VPOCHA(2,IB120)
           XERR100 = XERR100 + (UMAX1-UMIN1)
  129    CONTINUE
*--------moyenne des zones
         XREF1 = XREF1 + XREF100
         XERR1 = max(XERR1,XERR100)
*         write(6,*) 'XREF100,XERR100 = ',XREF100,XERR100
 
         endif
*--------fin deu cas (N.ne.0)
 
*--------quelques desactivations...
         segsup,mpova1
         segdes,IPT3,MPOVAL,MSOUPO
 
  100 CONTINUE
*-----fin de boucle sur les zones
 
 
***** ECART RELATIF A UNE TRANSLATION **********************************
*
      XREF1 = XREF1 / NSOUPO
      XERR1 = XERR1 / XREF1
*      write(6,*) '=> XREF1,XERR1 = ',XREF1,XERR1
 
 
      RETURN
      END