sd_fabsg4.f

Go to the documentation of this file.

!                   ********************
                    SUBROUTINE sd_fabsg4
!                   ********************
!
     &(npoin,nseg,dab1,dab2,dab3,dab4,xab1,xab2,xab3,xab4,
     & npblk,nsegblk,da,xa,typext1,typext2,typext3,typext4)
!
!***********************************************************************
! BIEF   V6P2                                   08/2012
!***********************************************************************
!
!brief    TRANSFORMS A 4-MATRIX SYSTEM INTO A SINGLE BLOCK.
!
!history  E. RAZAFINDRAKOTO (LNHE)
!+        20/11/06
!+        V5P7
!+
!
!history  N.DURAND (HRW), S.E.BOURBAN (HRW)
!+        13/07/2010
!+        V6P0
!+   Translation of French comments within the FORTRAN sources into
!+   English comments
!
!history  N.DURAND (HRW), S.E.BOURBAN (HRW)
!+        21/08/2010
!+        V6P0
!+   Creation of DOXYGEN tags for automated documentation and
!+   cross-referencing of the FORTRAN sources
!
!history  J. PARISI (LNHE)
!+        09/08/2012
!+        V6P2
!+   Considers the matrix types (symmetric or not) for each block.
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!| DA             |<--| RESULTING MATRIX DIAGONAL
!| DAB1           |-->| MATRIX DIAGONAL IN THE ORIGINAL SYSTEM
!| DAB2           |-->| MATRIX DIAGONAL IN THE ORIGINAL SYSTEM
!| DAB3           |-->| MATRIX DIAGONAL IN THE ORIGINAL SYSTEM
!| DAB4           |-->| MATRIX DIAGONAL IN THE ORIGINAL SYSTEM
!| NPBLK          |-->| RANK OF FINAL BLOCK MATRIX
!| NPOIN          |-->| NUMBER OF POINTS
!| NSEG           |-->| NUMBER OF SEGMENTS
!| NSEGBLK        |-->| NUMBER OF SEGMENTS IN FINAL BLOCK
!| Q              |-->| NON-SYMETRIC MATRIX
!| S              |-->| SYMETRIC MATRIX
!| TYPEXT1        |-->| TYPE OF MATRIX STORAGE : BLOCK 1
!| TYPEXT2        |-->| TYPE OF MATRIX STORAGE : BLOCK 2
!| TYPEXT3        |-->| TYPE OF MATRIX STORAGE : BLOCK 3
!| TYPEXT4        |-->| TYPE OF MATRIX STORAGE : BLOCK 4
!| XA             |<--| RESULTING OFF-DIAGONAL TERMS OF MATRIX
!| XAB1           |-->| OFF-DIAGONAL TERMS IN ORIGINAL SYSTEM
!| XAB2           |-->| OFF-DIAGONAL TERMS IN ORIGINAL SYSTEM
!| XAB3           |-->| OFF-DIAGONAL TERMS IN ORIGINAL SYSTEM
!| XAB4           |-->| OFF-DIAGONAL TERMS IN ORIGINAL SYSTEM
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!      USE BIEF, EX_SD_FABSG4 => SD_FABSG4
!
      USE declarations_special
      IMPLICIT NONE
!
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!
      INTEGER, INTENT(IN)             :: NSEGBLK,NPBLK,NSEG,NPOIN
      DOUBLE PRECISION, INTENT(IN)    :: XAB1(*),XAB2(*)
      DOUBLE PRECISION, INTENT(IN)    :: XAB3(*),XAB4(*)
      DOUBLE PRECISION, INTENT(IN)    :: DAB1(npoin),DAB2(npoin)
      DOUBLE PRECISION, INTENT(IN)    :: DAB3(npoin),DAB4(npoin)
      DOUBLE PRECISION, INTENT(INOUT) :: XA(2*nsegblk),DA(npblk)
      CHARACTER(LEN=1), INTENT(IN)    :: TYPEXT1,TYPEXT2
      CHARACTER(LEN=1), INTENT(IN)    :: TYPEXT3,TYPEXT4
!
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!
      INTEGER I,ISEG,JSEG
!
!----------------------------------------------
!     INFO :      NPBLK   = NPOIN*NBLOC
!                 NSEGBLK = NSEG*4 + 2*NPOIN
!----------------------------------------------
!
!
!
!-------------------
! 1.  BLOCK DIAGONAL
!-------------------
!
      DO i=1,npoin
        da(i) = dab1(i)
        da(i+npoin) = dab4(i)
      ENDDO
!
!---------------------------
! 2.   EXTRADIAGONAL TERMS
!---------------------------
!
!
!     BLOCK 1
!     ------
!
      jseg=0
!
      IF(typext1.EQ.'S') THEN
!
        DO iseg=1,nseg
          jseg=jseg+1
          xa(jseg)        =xab1(iseg)
          xa(jseg+nsegblk)=xab1(iseg)
        ENDDO
!
      ELSEIF(typext1.EQ.'Q') THEN
!
        DO iseg=1,nseg
          jseg=jseg+1
          xa(jseg)        =xab1(iseg)
          xa(jseg+nsegblk)=xab1(iseg+nseg)
        ENDDO

      ELSE
!
        WRITE(lu,*) 'SD_FABSG4: UNEXPECTED CASE'
        WRITE(lu,*) 'TYPEXT1=',typext1
        CALL plante(1)
        stop
!
      ENDIF
!
!     BLOCKS 2 AND 3 (EXTRA-DIAG)
!     ------------------------
      DO i=1,npoin
        jseg=jseg+1
        xa(jseg)        =dab2(i)
        xa(jseg+nsegblk)=dab3(i)
      ENDDO
!
      IF(typext2.EQ.'S'.AND.typext3.EQ.'S') THEN
!
        DO iseg=1,nseg
          jseg=jseg+1
          xa(jseg)        =xab2(iseg)
          xa(jseg+nsegblk)=xab3(iseg)
          jseg=jseg+1
          xa(jseg)        =xab2(iseg)
          xa(jseg+nsegblk)=xab3(iseg)
        ENDDO
!
      ELSEIF(typext2.EQ.'Q'.AND.typext3.EQ.'Q') THEN
!
        DO iseg=1,nseg
          jseg=jseg+1
          xa(jseg)        =xab2(iseg)
          xa(jseg+nsegblk)=xab3(iseg+nseg)
          jseg=jseg+1
          xa(jseg)        =xab2(iseg+nseg)
          xa(jseg+nsegblk)=xab3(iseg)
        ENDDO
!
      ELSE
!
        WRITE(lu,*) 'SD_FABSG4: UNEXPECTED CASE'
        WRITE(lu,*) 'TYPEXT2=',typext2,' TYPEXT3=',typext3
        CALL plante(1)
        stop
!
      ENDIF
!
!     BLOCK 4 (EXTRA)
!     --------------
!
      IF(typext4.EQ.'S') THEN
!
        DO iseg=1,nseg
          jseg=jseg+1
          xa(jseg)        =xab4(iseg)
          xa(jseg+nsegblk)=xab4(iseg)
        ENDDO
!
      ELSEIF(typext4.EQ.'Q') THEN
!
        DO iseg=1,nseg
          jseg=jseg+1
          xa(jseg)        =xab4(iseg)
          xa(jseg+nsegblk)=xab4(iseg+nseg)
        ENDDO
!
      ELSE
!
        WRITE(lu,*) 'SD_FABSG4: UNEXPECTED CASE'
        WRITE(lu,*) 'TYPEXT4=',typext4
        CALL plante(1)
        stop
!
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
      END