Télécharger kpro.eso

Retour à la liste

kpro
C KPRO      SOURCE    MB234859  26/11/04    21:15:06     12691          
      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
      SEGMENT ICPR(NBPTS)
 
      LOGICAL bSEGM,bRACC,bLIAI
 
C     Reading the CHPOINT
      CALL LIROBJ('CHPOINT',MCHP,1,IRET)
      IF (IERR.NE.0) RETURN
 
C     Reading the MAILLAGE
      CALL LIROBJ('MAILLAGE',MGEO,1,IRET)
      IF (IERR.NE.0) RETURN
 
C     Veryfing the MAILLAGE
      SEGACT,MGEO
      ITIPO=MGEO.ITYPEL
      bSEGM=(ITIPO.EQ.2 .OR. ITIPO.EQ.3 )
      bRACC=(ITIPO.EQ.12.OR. ITIPO.EQ.13)
      bLIAI=(ITIPO.GE.18.AND.ITIPO.LE.21)
      IF (.NOT.(bSEGM.OR.bRACC.OR.bLIAI)) THEN
        CALL ERREUR(16)
        RETURN
      ENDIF
C
C     Correspondance entre noeuds
      SEGINI,ICPR
      NELGEO=MGEO.NUM(/2)
      IF (bSEGM) THEN
        INOE=2
        IF (ITIPO.EQ.3) INOE=3
        DO IELT=1,NELGEO
          IPOIN1=MGEO.NUM(1,IELT)
          ICPR(IPOIN1)=1
        ENDDO
      ELSE
        NNOGEO=MGEO.NUM(/1)
        NNOGE2=NNOGEO/2
        DO IELT=1,NELGEO
          DO INOE=1,NNOGE2
            INOF=NNOGE2+INOE
            IF (bRACC) INOF=NNOGEO-INOE+1
            IPOIN1=MGEO.NUM(INOE,IELT)
            IPOIN2=MGEO.NUM(INOF,IELT)
            ICPR(IPOIN1)=IPOIN2
            ICPR(IPOIN2)=IPOIN1
          ENDDO
        ENDDO
      ENDIF
C
      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     =MAX(NELGEO,NELSPG)
        NBELEM=MAX(NELGEO,NELSPG)
        SEGINI,NSPG,NVAL
        NSPG.ITYPEL=1
 
        NPUNTO=0
        DO K=1,NELSPG
          IELSPG=MSPG.NUM(1,K)
          IPOIN3=ICPR(IELSPG)
          IF (IPOIN3.NE.0) THEN
            IF (bSEGM) THEN
              DO J=1,NELGEO
                IELGEO=MGEO.NUM(1,J)
                IF (IELGEO.EQ.IELSPG) THEN
                  NPUNTO=NPUNTO+1
                  NSPG.NUM(1,NPUNTO)=MGEO.NUM(INOE,J)
                  DO L=1,NC
                    NVAL.VPOCHA(NPUNTO,L)=MVAL.VPOCHA(K,L)
                  ENDDO
                ENDIF
              ENDDO
            ELSE
              NPUNTO=NPUNTO+1
              NSPG.NUM(1,NPUNTO)=IPOIN3
              DO L=1,NC
                NVAL.VPOCHA(NPUNTO,L)=MVAL.VPOCHA(K,L)
              ENDDO
            ENDIF
          ENDIF
        ENDDO
 
        IF (NPUNTO.EQ.0) THEN
          SEGSUP,NSPG,NVAL
          GOTO 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,NSPO,NSPG,NVAL,NCHP
 200    CONTINUE
        SEGDES,MSPO,MSPG,MVAL
 
      ENDDO
 
      SEGDES,MCHP
 
      IF (IPART.EQ.0) THEN
        CALL ERREUR(26)
        GOTO 1
      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
C
 1    CONTINUE
      SEGSUP,LOCSGM,ICPR
      END
 
 

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