i25edge_switch.F File Reference

#include "implicit_f.inc"
#include "assert.inc"
#include "i25edge_c.inc"
#include "param_c.inc"
#include "task_c.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	i25edge_switch (jtask, stifm, stfe, mvoisin, iedge, nedge, ledge)

Function/Subroutine Documentation

i25edge_switch()

subroutine i25edge_switch	(	integer, intent(in)	jtask,
		dimension(*), intent(in)	stifm,
		dimension(nedge), intent(inout)	stfe,
		integer, dimension(4,*), intent(in)	mvoisin,
		integer, intent(in)	iedge,
		integer, intent(in)	nedge,
		integer, dimension(nledge,*), intent(inout)	ledge )

Definition at line 30 of file i25edge_switch.F.

C-----------------------------------------------
C  In case of element deletion
C  LEDGE must be modified to keep the remaining
C  segment at the first position
C  If both element are deleted, STFE is set to negative 
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
#include      "assert.inc"
#include      "i25edge_c.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "param_c.inc"
#include      "task_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER, INTENT(IN) :: JTASK
      INTEGER, INTENT(IN) :: IEDGE, NEDGE
      INTEGER, INTENT(IN) :: MVOISIN(4,*)
      INTEGER, INTENT(INOUT) :: LEDGE(NLEDGE,*)
C     REAL
      my_real, INTENT(IN) :: stifm(*)
      my_real, INTENT(INOUT) :: stfe(nedge)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: NEDG,NEDGFT,NEDGLT
      INTEGER :: IRM,IEDG,JRM,JEDG 
      my_real :: s1,s2
      s1 = -huge(s1)
      s2 = -huge(s2)
      IF(iedge/=0)THEN
C
        nedgft= 1+(jtask-1)*nedge/ nthread
        nedglt= jtask*nedge/nthread
        DO nedg=nedgft,nedglt
          irm =ledge(ledge_left_seg,nedg)
          iedg=ledge(ledge_left_id,nedg)
          jrm =ledge(ledge_right_seg,nedg)
          jedg=ledge(ledge_right_id,nedg)
          IF(jrm/=0)THEN
 
            IF(irm > 0 .AND. jrm > 0) THEN
C not free, both segments are local to the SPMD domain
              s1 = stifm(irm)
              s2 = stifm(jrm)
            ELSEIF(irm < 0 .AND. jrm > 0) THEN
C if IRM is negative, then JRM must be zero
C because split_interface
              assert(.false.)
C edge at the boundary of spmd domains
C secnd side treated by the other domain 
              s1 = one ! exact stiffness not known, but it is nnz
C MVOISIN = 0 <=> STFM( VOISIN )) = 0
              IF(mvoisin(jedg,jrm) == 0 ) s1 = zero
              s2 = stifm(jrm)
            ELSEIF(irm > 0 .AND. jrm < 0) THEN
C edge at the boundary of SPMD domains
C secnd side treated by ISPMD
              s1 = stifm(irm)
!exact stiffness on the other side of the boundary is not known yet
! But we can determine if it is zero or not according to MVOISIN
              s2 = one 
              IF(mvoisin(iedg,irm) == 0) s2 = zero
            ELSE
C not supposed to be there
              assert(.false.)
            ENDIF
 
            IF(s1 == zero)THEN
C first (left) segment is broken
C new left <= old right
C old right <= 0 
C in order to always have the unbroken segment in the first place
C            DEBUG_E2E(LEDGE(LEDGE_GLOBAL_ID,NEDG) == D_EM,S1)
C            DEBUG_E2E(LEDGE(LEDGE_GLOBAL_ID,NEDG) == D_ES,S1)
 
CC ???????????????????????????????????????????????
              IF(jrm > 0) THEN
                ledge(ledge_left_seg,nedg) = jrm
                ledge(ledge_left_id,nedg) = jedg
              ELSEIF (jrm < 0)  THEN
                ledge(ledge_left_seg,nedg) = -abs(irm) !1
C               LEDGE(LEDGE_LEFT_SEG,NEDG) = JEDG      !2
               ! LEDGE(LEDGE_LEFT_ID,NEDG) unchanged
              ENDIF
C             tag for comm in spmd_getstif25_edg
              IF(ledge(ledge_weight,nedg) == 1) THEN
                ledge(ledge_global_id,nedg) = -abs(ledge(ledge_global_id,nedg))
              ENDIF
CC ???????????????????????????????????????????????
 
              ledge(ledge_seg1_im,nedg) = ledge(ledge_seg2_im,nedg)
              ledge(ledge_seg1_i1,nedg) = ledge(ledge_seg2_i1,nedg)
              ledge(ledge_seg1_i2,nedg) = ledge(ledge_seg2_i2,nedg)
              ledge(ledge_right_seg,nedg) = 0
 
              IF(jrm >= 0) THEN
                ledge(ledge_right_id,nedg) = 0
              ELSE
 
              ENDIF
 
            ELSEIF(s2 == zero)THEN
C left segment has broken
C             DEBUG_E2E(LEDGE(LEDGE_GLOBAL_ID,NEDG) == D_EM,S2)
C             DEBUG_E2E(LEDGE(LEDGE_GLOBAL_ID,NEDG) == D_ES,S2)
              ledge(ledge_right_seg,nedg) = 0
              ledge(ledge_right_id,nedg) = 0
 
C             tag for comm in spmd_getstif25_edg
              IF(ledge(ledge_weight,nedg) == 1) THEN
                ledge(ledge_global_id,nedg) = -abs(ledge(ledge_global_id,nedg))
              ENDIF
 
 
            END IF          
          END IF
        END DO
 
C=======================================================================
        DO nedg = nedgft,nedglt
          irm = ledge(ledge_left_seg,nedg)
          jrm = ledge(ledge_right_seg,nedg)
C         DEBUG_E2E(LEDGE(LEDGE_GLOBAL_ID,NEDG) == D_ES,STFE(NEDG))
 
          IF(irm > 0) THEN
C on peut passer ici: cas d edge de bord
C dont le irect casse (o ne passe pas dans le switch (1,2) <- (3,4) au dessus
C           DEBUG_E2E(LEDGE(LEDGE_GLOBAL_ID,NEDG) == D_ES,STIFM(IRM))
            IF(stifm(irm)==zero)THEN
              IF(stfe(nedg) > zero) THEN
                 stfe(nedg) = -stfe(nedg)
              ENDIF
            ENDIF
          ELSE IF(irm < 0) THEN
! Edge frontiere 
! The only way that IRM < 0  is when
C   -  the a boundary edge owned by ISPMD
!   -  the local segment is broken
 
C 1      -1 IRM 
C 1       1 IEDG
C -1      0 JRM         
C 1       0 JEDG 
            s1 = one
            iedg=ledge(ledge_left_id ,nedg)
            IF(jrm ==  0) THEN
              IF(mvoisin(iedg,abs(irm))==0) s1 = zero
C  When IRM < 0 and JRM == 0
C  STFE is 0 if the other side is broken too 
C Because we always put the remaining segment first (IRM,IEDG) 
C we need to check
C           ELSE IF( ) THEN
C             S1 = 0
            ELSE
              assert(.false.)
            ENDIF
           
            IF(s1==zero)THEN
              IF(stfe(nedg) > zero) THEN
                 stfe(nedg) = -stfe(nedg)
              ENDIF
            ENDIF
 
          ELSEIF (irm == 0) THEN
            assert(.false.) ! 
            IF(stfe(nedg) > zero) THEN
               stfe(nedg) = -stfe(nedg)
            END IF          
          END IF
        END DO
 
        CALL my_barrier
      END IF ! IEDGE
      RETURN