Sources Esope | Cast3M

kparc
C KPARC     SOURCE    CHAT      05/01/13    01:03:56     5004
      SUBROUTINE  KPARC(KG,KBITM,NR,NINT,IINT,NMAX,IS,JS,NSTAC)         KPA00010
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C Calcul des facteurs de forme en 3D
C sp appele par KREMPI
C     DETERMINATION DE L'ENSEMBLE DES POINTS INTERIEURS A UN CONTOUR
C     DONNE (DANS UNE BITMAP) REPERE PAR DES 1
C                                                                       KPA00040
C     REM   TAILLE MAX DE STACK = NSTAC
C     ***
C
      DIMENSION IINT(2,1)                                               KPA00020
      DIMENSION KG(2),KBITM(NR,NR),IADJ(4),JADJ(4)                      KPA00020
      DIMENSION IS(NSTAC),JS(NSTAC)                                       KPA000
      NS = 0                                                            KPA00050
      CALL KPUSH(IS,JS,NS,KG(1),KG(2))                                  KPA00060
      NINT = 0                                                          KPA00070
      KBITM(KG(1),KG(2)) = 2                                            KPA00080
C                                                                       KPA00090
 1    CONTINUE                                                          KPA00100
      IF (NS.EQ.0) THEN                                                 KPA00110
         RETURN                                                         KPA00120
      ELSE                                                              KPA00130
         CALL KPOP(IS,JS,NS,IP,JP)                                      KPA00140
 11      CONTINUE                                                       KPA00150
 
         IF(NINT.GE.NMAX) RETURN
         NINT = NINT + 1                                                KPA00160
         IINT(1,NINT) = IP                                              KPA00170
         IINT(2,NINT) = JP                                              KPA00180
 
         CALL  KADJ(IP,JP,KBITM,NR,NADJ,IADJ,JADJ)                      KPA00190
         IF (NADJ.EQ.0) THEN                                            KPA00200
           GOTO 1                                                       KPA00210
         ELSE                                                           KPA00220
           IF(NADJ.GE.2) THEN                                           KPA00230
             DO 111 K = 2,NADJ                                          KPA00240
                IP = IADJ(K)                                            KPA00250
                JP = JADJ(K)                                            KPA00260
                CALL KPUSH(IS,JS,NS,IP,JP)                              KPA00270
                KBITM(IP,JP) = 2                                        KPA00290
 111         CONTINUE                                                   KPA00300
           ENDIF                                                        KPA00310
         IP = IADJ(1)                                                   KPA00320
         JP = JADJ(1)                                                   KPA00330
         KBITM(IP,JP) = 2                                               KPA00340
         GOTO 11                                                        KPA00350
         ENDIF                                                          KPA00360
      ENDIF                                                             KPA00370
      END                                                               KPA00380