Télécharger la plaquette Cast3M


fr en

Télécharger tabgau.eso

Retour à la liste

Numérotation des lignes : 

tabgau

  1. C TABGAU    SOURCE    FANDEUR   10/12/06    21:15:34     6804
  2.       SUBROUTINE TABGAU(IPMINT,IREREF,IRECHAM,NBNN,IREF,
  3.      +        ICHAM,NBPGAU,IRET,wTRAV)
  4. *
  5.       IMPLICIT INTEGER(I-N)
  6.       IMPLICIT REAL*8(A-H,O-Z)
  7. *
  8. *  modif PV la creation suppression de wtrav se fait dans testma
  9. *  les definitions doivent donc être coherentes
  10.  
  11. -INC PPARAM
  12. -INC CCOPTIO
  13. -INC SMELEME
  14. -INC SMCOORD
  15. -INC SMINTE
  16. *
  17.       SEGMENT WTRAV
  18.         REAL*8 QSIREF(NBPGAU),QSICHAM(NBPGAU),ETAREF(NBPGAU)
  19.         REAL*8 ETACHAM(NBPGAU),DZEREF(NBPGAU),DZECHAM(NBPGAU)
  20.         REAL*8 XECHAM(3,NBNN),XEREF(3,NBNN)
  21.         INTEGER TABOK(NBPGAU),TAB(NBPGAU)
  22.       ENDSEGMENT
  23. *
  24.       MINTE=IPMINT
  25.       MELEME=IREF
  26.       IPT2=ICHAM
  27. *
  28. *     RECUPERER LES COORD HOMOGENES DES 2 SERIES DE PTS DE GAUSS
  29. *
  30.        CALL DOXE(XCOOR,IDIM,NBNN,IPT2.NUM,IRECHAM,XECHAM)
  31.        CALL DOXE(XCOOR,IDIM,NBNN,NUM,IREREF,XEREF)
  32. *
  33.        DO 1 I=1,NBPGAU
  34.         c1cham=0.
  35.         c2cham=0.
  36.         c3cham=0.
  37.         c1ref =0.
  38.         c2ref =0.
  39.         c3ref =0.
  40.         DO 11 J=1,NBNN
  41.           r_z = SHPTOT(1,J,I)
  42.           c1CHAM= c1CHAM + r_z * XECHAM(1,J)
  43.           c2CHAM= c2CHAM + r_z * XECHAM(2,J)
  44.           c1REF = c1REF  + r_z * XEREF(1,J)
  45.           C2REF = C2REF  + r_z * XEREF(2,J)
  46.           IF (IDIM.EQ.3) THEN
  47.             C3CHAM = C3CHAM + r_z * XECHAM(3,J)
  48.             C3REF  = C3REF  + r_z * XEREF(3,J)
  49.          ENDIF
  50.  11    CONTINUE
  51.         qsicham(i)=c1cham
  52.         etacham(i)=c2cham
  53.         dzecham(i)=c3cham
  54.         qsiref(i) =c1ref
  55.         etaref(i) =c2ref
  56.         dzeref(i) =c3ref
  57.  1    CONTINUE
  58. *
  59.       PREC=1.E-10
  60.       DO 10 I=1,NBPGAU
  61.        tab(i)=0
  62.        tabok(i)=0
  63.        PRECA= ABS(PREC*QSIREF(I))
  64.        PRECB= ABS(PREC*ETAREF(I))
  65.        PRECC= ABS(PREC*DZEREF(I))
  66.        DO 10 J=1,NBPGAU
  67.          IF (TABOK(I).EQ.0) THEN
  68.            A= ABS(QSIREF(I)-QSICHAM(J))
  69.            B= ABS(ETAREF(I)-ETACHAM(J))
  70.            C= ABS(DZEREF(I)-DZECHAM(J))
  71.            IF (A.LE.PRECA.AND.B.LE.PRECB.AND.C.LE.PRECC)   THEN
  72.              TAB(I)=J
  73.              TABOK(I)=1
  74.            ENDIF
  75.          ENDIF
  76.  10    CONTINUE
  77. *
  78.       IRET=1
  79.        DO 20 I=1,NBPGAU
  80.          IF (TABOK(I).EQ.0) THEN
  81.             IRET=0
  82.             GOTO 30
  83.          ENDIF
  84.  20    CONTINUE
  85. *
  86.  30    CONTINUE
  87.  
  88.       RETURN
  89.       END
  90.  
  91.  
  92.  

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