Télécharger la plaquette Cast3M


fr en

Télécharger excopp.eso

Retour à la liste

Numérotation des lignes : 

excopp

  1. C EXCOPP    SOURCE    CB215821  25/04/23    21:15:20     12247          
  2.       SUBROUTINE EXCOPP(IPCH1,MOT,NIF1,IPCH2,MOT2,NIF2,IVID)
  3. C=======================================================================
  4. C
  5. C               EXTRACTION D UNE COMPOSANTE D UN CHPOINT
  6. C               ROUTINE APPELLEE PAR L OPERATEUR EXCOMP
  7. C ENTREE
  8. C     IPCH1= POINTEUR SUR UN CHPOINT
  9. C     MOT  = NOM DE LA COMPOSANTE A EXTRAIRE
  10. C     NIF1 = harmonique de Fourier
  11. C SORTIE
  12. C     IPCH2= POINTEUR SUR LE CHPOINT CONTENANT UNIQUEMENT LA
  13. C            COMPOSANTE  MOT LE NOM DE CETTE COMPOSANTE EST
  14. C            REPABTISE  MOT2 + harmonique NIF2
  15. C     CODE DECEMBRE 84 MODIFIE NOVEMBRE 1986
  16. C=======================================================================
  17.       IMPLICIT INTEGER(I-N)
  18.       IMPLICIT REAL*8 (A-H,O-Z)
  19.  
  20. -INC SMCHPOI
  21. -INC SMCOORD
  22. -INC SMELEME
  23. -INC PPARAM
  24. -INC CCOPTIO
  25.  
  26.       CHARACTER*(*) MOT,MOT2
  27.       CHARACTER*(LOCOMP) MOT1
  28. C
  29. c     write(*,*) 'EXCOPP: search ',MOT,NIF1,' a renommer en ',MOT2,NIF2
  30.       MCHPO1=IPCH1
  31. C
  32. C     INITIALISATION DES SEGMENTS DE TRAVAIL
  33. C
  34. C
  35.       MPOVAL=0
  36.       IPT1  =0
  37.       NBSOUS=0
  38.       NBREF =0
  39.       NSOUP1=MCHPO1.IPCHP(/1)
  40. C
  41. C     BOUCLE SUR LES SOUS PAQUETS DE MCHPO1
  42. C
  43.       DO 100 IA=1,NSOUP1
  44.         MSOUP1=MCHPO1.IPCHP(IA)
  45.         NC1=MSOUP1.NOCOMP(/2)
  46.         DO 110 IB=1,NC1
  47.           MOT1=MSOUP1.NOCOMP(IB)
  48.           IHA =MSOUP1.NOHARM(IB)
  49.           IF(MOT1.NE.MOT .OR. IHA.NE.NIF1)  GOTO 110
  50.           IBVAL=IB
  51.           GOTO 120
  52.   110   CONTINUE
  53. C
  54. C       ON A PAS TROUVE UNE COMPOSANTE MOT DANS CE SOUS PAQUET
  55. C
  56.         GOTO 130
  57. C
  58. C       ON A TROUVE DANS LE SOUS PAQUET UNE COMPOSANTE MOT
  59. C
  60.  120    CONTINUE
  61.         MELEME=MSOUP1.IGEOC
  62.         MPOVA1=MSOUP1.IPOVAL
  63.         NBNN  =NUM(/1)
  64.         NBELEM=NUM(/2)
  65.         IF(MPOVAL.EQ.0) THEN
  66.            NDEJ=0
  67.            NC  =1
  68.            N   =NBELEM
  69.            SEGINI,MPOVAL,IPT1
  70.         ELSE
  71.            NC    =1
  72.            N     =NBELEM+NDEJ
  73.            NBELEM=N
  74.            SEGADJ,MPOVAL,IPT1
  75.         ENDIF
  76.         DO 140 IC=1,NUM(/2)
  77.           IPT1.NUM(1,IC+NDEJ)=NUM(1,IC)
  78.           MPOVAL.VPOCHA(IC+NDEJ,1)=MPOVA1.VPOCHA(IC,IBVAL)
  79.  140    CONTINUE
  80.  
  81.         NDEJ=NDEJ+NUM(/2)
  82.  130    CONTINUE
  83.  100  CONTINUE
  84. C
  85.  
  86.       IF(MPOVAL.NE.0)  GOTO 200
  87. C
  88. C     ERREUR PAS DE COMPOSANTE DU TYPE RECHERCHE DANS MCHPOI
  89. C
  90.       IF(IVID.EQ.1) THEN
  91.           NSOUPO=0
  92.           NAT=MCHPO1.JATTRI(/1)
  93.           SEGINI,MCHPOI
  94.           mochde='chpoint vide'
  95.           mtypoi='SCALAIRE'
  96.           IFOPOI=MCHPO1.IFOPOI
  97.           DO 160 II=1,NAT
  98.              JATTRI(II)=MCHPO1.JATTRI(II)
  99.  160      CONTINUE
  100.           IPCH2=MCHPOI
  101.           RETURN
  102.       ELSE
  103.           MOTERR=MOT
  104.           CALL ERREUR(181)
  105.           RETURN
  106.       ENDIF
  107.   200 CONTINUE
  108. C
  109. C     ON REMPLIT LE NOUVEAU CHPOINT
  110. C
  111.       NSOUPO=1
  112.       NAT=MCHPO1.JATTRI(/1)
  113.       SEGINI,MCHPOI
  114.       IPCH2=MCHPOI
  115.       MTYPOI='SCALAIRE'
  116.       MOCHDE=MCHPO1.MOCHDE
  117.       DO 170 II=1,NAT
  118.           JATTRI(II)=MCHPO1.JATTRI(II)
  119.  170  CONTINUE
  120.       IFOPOI=MCHPO1.IFOPOI
  121.       NC=1
  122.       SEGINI,MSOUPO
  123.       IPCHP(1)=MSOUPO
  124.       NOCOMP(1)=MOT2
  125.  
  126.       NOHARM(1)=NIF2
  127.       IPOVAL=MPOVAL
  128.       IPT1.ITYPEL=1
  129.       call crech1(ipt1,1)
  130.       IGEOC=IPT1
  131.  
  132.       END
  133.  
  134.  
  135.  
  136.  
  137.  

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