Télécharger kpro.eso

Retour à la liste

kpro
C KPRO      SOURCE    PV        22/01/04    06:13:28     11250          
      SUBROUTINE KPRO
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C*************************************************************************
C
C     Operateur KPRO
C
C     OBJET    : to project CHAMPOINT
C     SYNTAXE  : CHR = KPRO CHP GEO ;
C
C                CHP  : CHPOINT
C                CHR  : CHPOINT
C                GEO  : MAILLAGE (SEG2 or SEG3)
C
C  CHR is the projection of CHP following the connectivities GEO.
C  The value of CHP at point 1 of each element of GEO (if exists)
C  is projected to the point 2 of the same element of GEO thus to
C  constitute CHR.
C
C*************************************************************************
      CHARACTER*8 TYPE
 
 
-INC PPARAM
-INC CCOPTIO
-INC SMCOORD
-INC SMCHPOI
      POINTEUR MCHP.MCHPOI,MSPO.MSOUPO,MVAL.MPOVAL
      POINTEUR NCHP.MCHPOI,NSPO.MSOUPO,NVAL.MPOVAL
-INC SMELEME
      POINTEUR MGEO.MELEME,MSPG.MELEME,NSPG.MELEME
 
      SEGMENT LOCSGM
       INTEGER  ICHP(NPART)
      ENDSEGMENT
 
C***
 
C     Reading the CHPOINT
 
      TYPE='CHPOINT '
      CALL LIROBJ(TYPE,MCHP,0,IRET)
      IF(IRET.EQ.0) THEN
      WRITE(6,*)'On attend un CHAMPOINT'
      RETURN
      ENDIF
 
C     Reading the MAILLAGE
 
      TYPE='MAILLAGE'
      CALL LIROBJ(TYPE,MGEO,0,IRET)
      IF(IRET.EQ.0) THEN
      WRITE(6,*)'On attend un MAILLAGE'
      RETURN
      ENDIF
 
C     Veryfing the MAILLAGE
      inoeu = 2
      SEGACT MGEO
      ITIPO=MGEO.ITYPEL
      IF(ITIPO.LT.2.OR.ITIPO.GT.3) THEN
      WRITE(6,*)'On attend un MAILLAGE compose de SEG2 ou SEG3'
      RETURN
      ENDIF
      if(itipo.eq.3)  inoeu = 3
      NELGEO=MGEO.NUM(/2)
      NBNN  =1
      NBSOUS=0
      NBREF =0
 
      SEGACT MCHP
 
      NPART=MCHP.IPCHP(/1)
      NAT  =MCHP.JATTRI(/1)
      SEGINI LOCSGM
 
      IPART=0
      DO I=1,NPART
 
        MSPO=MCHP.IPCHP(I)
        SEGACT MSPO
 
        MSPG=MSPO.IGEOC
        MVAL=MSPO.IPOVAL
        SEGACT MSPG,MVAL
 
        NC    =MVAL.VPOCHA(/2)
        NELSPG=MSPG.NUM(/2)
        N     =NELGEO
        NBELEM=NELGEO
        SEGINI NSPG,NVAL
        NSPG.ITYPEL=1
 
        NPUNTO=0
        DO J=1,NELGEO
          DO K=1,NELSPG
            IELGEO=MGEO.NUM(1,J)
            IELSPG=MSPG.NUM(1,K)
            IF(IELGEO.EQ.IELSPG) THEN
              NPUNTO=NPUNTO+1
              NSPG.NUM(1,NPUNTO)=MGEO.NUM(inoeu,J)
              DO L=1,NC
                NVAL.VPOCHA(NPUNTO,L)=MVAL.VPOCHA(K,L)
              ENDDO
              GO TO 100
            ENDIF
          ENDDO
100       CONTINUE
        ENDDO
 
        IF(NPUNTO.EQ.0) THEN
           SEGSUP NSPG,NVAL
           SEGDES MSPG,MVAL,MSPO
           GO TO 200
        ELSEIF(NPUNTO.NE.NBELEM) THEN
           NBELEM=NPUNTO
           N     =NPUNTO
           SEGADJ NSPG,NVAL
        ENDIF
 
        SEGINI NSPO
        NSPO.IGEOC =NSPG
        NSPO.IPOVAL=NVAL
        DO L=1,NC
          NSPO.NOCOMP(L)=MSPO.NOCOMP(L)
          NSPO.NOHARM(L)=MSPO.NOHARM(L)
        ENDDO
 
        NSOUPO=1
        SEGINI NCHP
        NCHP.MTYPOI  =MCHP.MTYPOI
        NCHP.MOCHDE  =MCHP.MOCHDE
        NCHP.IFOPOI  =MCHP.IFOPOI
        NCHP.IPCHP(1)=NSPO
        DO L=1,NAT
          NCHP.JATTRI(L)=MCHP.JATTRI(L)
        ENDDO
 
        IPART=IPART+1
        ICHP(IPART)=NCHP
 
        SEGDES NCHP,NSPO,NSPG,NVAL,MSPG,MVAL,MSPO
 
200     CONTINUE
 
      ENDDO
 
      SEGDES MCHP
 
      IF(IPART.EQ.0) THEN
        WRITE(ioimp,*) 'Le CHPOINT et le MAILLAGE n''ont pas ',
     &                 'de point commun'
        SEGSUP LOCSGM
        RETURN
      ENDIF
 
      NCHP=ICHP(1)
      CALL ECROBJ('CHPOINT ',NCHP)
 
      IF(IPART.GT.1) THEN
        DO I=2,IPART
          NCHP=ICHP(I)
          CALL ECROBJ('CHPOINT ',NCHP)
          CALL PRFUSE
        ENDDO
      ENDIF
 
      SEGSUP LOCSGM
 
      RETURN
      END
 
 
 
 

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