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  20/11/25    13:28:31     10792          
  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 SMELEME
  22. -INC PPARAM
  23. -INC CCOPTIO
  24.  
  25.       CHARACTER*(*) MOT,MOT2
  26.       CHARACTER*(LOCOMP) MOT1
  27. C
  28. c     write(*,*) 'EXCOPP: search ',MOT,NIF1,' a renommer en ',MOT2,NIF2
  29.       MCHPO1=IPCH1
  30. C
  31. C     INITIALISATION DES SEGMENTS DE TRAVAIL
  32. C
  33. C
  34.       MPOVAL=0
  35.       IPT1  =0
  36.       NBSOUS=0
  37.       NBREF =0
  38.       NSOUP1=MCHPO1.IPCHP(/1)
  39. C
  40. C     BOUCLE SUR LES SOUS PAQUETS DE MCHPO1
  41. C
  42.       DO 100 IA=1,NSOUP1
  43.         MSOUP1=MCHPO1.IPCHP(IA)
  44.         NC1=MSOUP1.NOCOMP(/2)
  45.         DO 110 IB=1,NC1
  46.           MOT1=MSOUP1.NOCOMP(IB)
  47.           IHA =MSOUP1.NOHARM(IB)
  48.           IF(MOT1.NE.MOT .OR. IHA.NE.NIF1)  GOTO 110
  49.           IBVAL=IB
  50.           GOTO 120
  51.   110   CONTINUE
  52. C
  53. C       ON A PAS TROUVE UNE COMPOSANTE MOT DANS CE SOUS PAQUET
  54. C
  55.         GOTO 130
  56. C
  57. C       ON A TROUVE DANS LE SOUS PAQUET UNE COMPOSANTE MOT
  58. C
  59.  120    CONTINUE
  60.         MELEME=MSOUP1.IGEOC
  61.         MPOVA1=MSOUP1.IPOVAL
  62.         NBNN  =NUM(/1)
  63.         NBELEM=NUM(/2)
  64.         IF(MPOVAL.EQ.0) THEN
  65.            NDEJ=0
  66.            NC  =1
  67.            N   =NBELEM
  68.            SEGINI,MPOVAL,IPT1
  69.         ELSE
  70.            NC    =1
  71.            N     =NBELEM+NDEJ
  72.            NBELEM=N
  73.            SEGADJ,MPOVAL,IPT1
  74.         ENDIF
  75.         DO 140 IC=1,NUM(/2)
  76.           IPT1.NUM(1,IC+NDEJ)=NUM(1,IC)
  77.           MPOVAL.VPOCHA(IC+NDEJ,1)=MPOVA1.VPOCHA(IC,IBVAL)
  78.  140    CONTINUE
  79.  
  80.         NDEJ=NDEJ+NUM(/2)
  81.  130    CONTINUE
  82.  100  CONTINUE
  83. C
  84.  
  85.       IF(MPOVAL.NE.0)  GOTO 200
  86. C
  87. C     ERREUR PAS DE COMPOSANTE DU TYPE RECHERCHE DANS MCHPOI
  88. C
  89.       IF(IVID.EQ.1) THEN
  90.           NSOUPO=0
  91.           NAT=MCHPO1.JATTRI(/1)
  92.           SEGINI,MCHPOI
  93.           mochde='chpoint vide'
  94.           mtypoi='SCALAIRE'
  95.           IFOPOI=MCHPO1.IFOPOI
  96.           DO 160 II=1,NAT
  97.              JATTRI(II)=MCHPO1.JATTRI(II)
  98.  160      CONTINUE
  99.           IPCH2=MCHPOI
  100.           RETURN
  101.       ELSE
  102.           MOTERR=MOT
  103.           CALL ERREUR(181)
  104.           RETURN
  105.       ENDIF
  106.   200 CONTINUE
  107. C
  108. C     ON REMPLIT LE NOUVEAU CHPOINT
  109. C
  110.       NSOUPO=1
  111.       NAT=MCHPO1.JATTRI(/1)
  112.       SEGINI,MCHPOI
  113.       IPCH2=MCHPOI
  114.       MTYPOI='SCALAIRE'
  115.       MOCHDE=MCHPO1.MOCHDE
  116.       DO 170 II=1,NAT
  117.           JATTRI(II)=MCHPO1.JATTRI(II)
  118.  170  CONTINUE
  119.       IFOPOI=MCHPO1.IFOPOI
  120.       NC=1
  121.       SEGINI,MSOUPO
  122.       IPCHP(1)=MSOUPO
  123.       NOCOMP(1)=MOT2
  124.  
  125.       NOHARM(1)=NIF2
  126.       IPOVAL=MPOVAL
  127.       IPT1.ITYPEL=1
  128.       call crech1(ipt1,1)
  129.       IGEOC=IPT1
  130.  
  131.       END
  132.  
  133.  
  134.  
  135.  

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