Télécharger la plaquette Cast3M


fr en

Télécharger moco.eso

Retour à la liste

Numérotation des lignes : 

moco

  1. C MOCO      SOURCE    PV        05/09/22    21:19:46     5181
  2. C  ECRITURE COORDONNES D'UN POINT
  3. C
  4.       SUBROUTINE MOCO(XPROJ,IVU,KON1,IDCP,ICPR,IBOUJ)
  5.       IMPLICIT INTEGER(I-N)
  6.       SEGMENT XPROJ(3,0)
  7.       SEGMENT IVU(0)
  8.       SEGMENT IDCP(0)
  9.       SEGMENT ICPR(0)
  10.       SEGMENT IBOUJ(0)
  11.       SEGMENT /KON1/(KON(NBCON,NMAX)),KON2.KON1
  12.  
  13. -INC PPARAM
  14. -INC CCOPTIO
  15. -INC SMCOORD
  16.       COMMON /CMODI/LIGMAX,XPREC,YPREC
  17.       DIMENSION XTR(2),YTR(2),ZTR(2)
  18.       CHARACTER*12 ZONE1,ZONE2,ZONE3,ZONF1,ZONF2,ZONF3
  19.       CHARACTER*29 MESSAG
  20.       CHARACTER*9 KEGEND(5)
  21.       ZTR(1)=0
  22.       ZTR(2)=0
  23.       IMOD=0
  24.       NBCON=KON(/1)
  25.       NBCONR=NBCON-1
  26. *  RECHERCHE DU POINT
  27.       CALL mopf3
  28.       CALL TRMESS('Pointez le point')
  29.   30  CONTINUE
  30.       CALL TRDIG(X,Y,INCLE)
  31.       IF (INCLE.EQ.3) RETURN
  32. *  CHERCHER LE POINT DU MAILLAGE
  33.       NBP=XPROJ(/2)
  34.       CRIT=XPREC**2
  35.       DO 10 IP=1,NBP
  36.       IF (IVU(IP).NE.1) GOTO 10
  37.       DIST=(XPROJ(1,IP)-X)**2+(XPROJ(2,IP)-Y)**2
  38.       IF (DIST.LT.CRIT) GOTO 20
  39.   10  CONTINUE
  40.       GOTO 30
  41.   20  CONTINUE
  42.       IPREL=IDCP(IP)
  43.       IREF=(IPREL-1)*(IDIM+1)
  44.       MESSAG='Coordonnees du point'
  45.       WRITE (MESSAG(23:28),FMT='(I6)') IPREL
  46.       ZONE1=' '
  47.       ZONE2=' '
  48.       ZONE3=' '
  49.       WRITE (ZONE2,FMT='(E12.6)') XCOOR(2+IREF)
  50.       IF (IDIM.EQ.3) THEN
  51.        WRITE (ZONE3,FMT='(E12.6)') XCOOR(3+IREF)
  52.       ENDIF
  53.       WRITE (ZONE1,FMT='(E12.6)') XCOOR(1+IREF)
  54.       CALL TRMESS(MESSAG//ZONE1//ZONE2//ZONE3)
  55.       GOTO 90
  56.   80  CONTINUE
  57.       CALL TRMESS('Valeur incorrecte')
  58.   90  CONTINUE
  59.       KEGEND(1)=' '
  60.       KEGEND(2)='Changer X'
  61.       KEGEND(3)='Changer Y'
  62.       KEGEND(4)='Changer Z'
  63.       IF (IDIM.NE.3) KEGEND(4)=' '
  64.       KEGEND(5)='Continuer'
  65.       CALL MENU(KEGEND,4,9)
  66.       CALL TRAFF(ICLE)
  67.       IF (ICLE.EQ.1) THEN
  68.       CALL TRGET('Indiquer le nouveau X :',ZONF1)
  69.       READ(ZONF1,FMT='(E12.6)',ERR=80) XCOOR(1+IREF)
  70.       IMOD=1
  71.       ENDIF
  72.       IF (ICLE.EQ.2) THEN
  73.       CALL TRGET('Indiquer le nouveau Y :',ZONF2)
  74.       READ(ZONF2,FMT='(E12.6)',ERR=80) XCOOR(2+IREF)
  75.       IMOD=1
  76.       ENDIF
  77.       IF (IDIM.EQ.3) THEN
  78.       IF (ICLE.EQ.3) THEN
  79.       CALL TRGET('Indiquer le nouveau Z :',ZONF3)
  80.       READ(ZONF3,FMT='(E12.6)',ERR=80) XCOOR(3+IREF)
  81.       IMOD=1
  82.       ENDIF
  83.       ENDIF
  84. *  REAFFICHER LES LIGNES MODIFIES
  85.       IF (IMOD.EQ.0) RETURN
  86.       CALL PROMOD(ICPR,XPROJ,IPREL,3,IBOUJ)
  87.       CALL CHCOUL(4)
  88.       X=XPROJ(1,IP)
  89.       Y=XPROJ(2,IP)
  90.       ICHAIN=IP
  91.   70  CONTINUE
  92.       DO 50 ICON=1,NBCONR
  93.       IP=KON(ICON,ICHAIN)
  94.       IF (IP.EQ.0) GOTO 60
  95.       XTR(1)=X
  96.       YTR(1)=Y
  97.       XTR(2)=XPROJ(1,IP)
  98.       YTR(2)=XPROJ(2,IP)
  99.       CALL POLRL(2,XTR,YTR,ZTR)
  100.   50  CONTINUE
  101.       ICHAIN=KON(NBCON,ICHAIN)
  102.       IF (ICHAIN.NE.0) GOTO 70
  103.   60  CONTINUE
  104.       END
  105.  
  106.  
  107.  

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