anchor.diff:    !                    on exit      solution vector
     !           iv       communication array
     !======================================================================!
  -  SUBROUTINE NUSOL0(R_h_s,Ir)
  -    USE HECMW_UTIL
  -    IMPLICIT NONE
  -    !------
  -    INTEGER, INTENT(OUT):: Ir
  -    REAL(KIND=8), INTENT(OUT):: R_h_s(*)
  -    !------
  -    INTEGER:: lwk
  -    INTEGER:: ndegl
  -    REAL(KIND=8), POINTER :: wk(:)
  -
  -    IF ( STAge/=30 .AND. STAge/=40 ) THEN
  +  subroutine NUSOL0(R_h_s,Ir)
  +    use HECMW_UTIL
  +    implicit none
  +    !------
  +    integer, intent(OUT):: Ir
  +    real(KIND=8), intent(OUT):: R_h_s(*)
  +    !------
  +    integer:: lwk
  +    integer:: ndegl
  +    real(KIND=8), pointer :: wk(:)
  +
  +    if ( STAge/=30 .and. STAge/=40 ) then
         Ir = 50
  -      RETURN
  -    ELSE
  +      return
  +    else
         Ir = 0
  -    ENDIF
  +    endif
       lwk = TOTal
   
  -    ALLOCATE (wk(NDEg*NEQns),STAT=IERror)
  -    IF ( IERror/=0 ) THEN
  -      WRITE (*,*) "##Error: not enough memory"
  -      CALL HECMW_ABORT(HECMW_COMM_GET_COMM())
  -    ENDIF
  +    allocate (wk(NDEg*NEQns),STAT=IERror)
  +    if ( IERror/=0 ) then
  +      write (*,*) "##Error: not enough memory"
  +      call HECMW_ABORT(HECMW_COMM_GET_COMM())
  +    endif
       !rmiv
       ndegl = NDEg*(NDEg+1)
       ndegl = ndegl/2
   
  -    SELECT CASE( NDEg )
  -    CASE (1)
  -      CALL NUSOL1(XLNzr,COLno,DSLn,ZLN,DIAg,IPErm,R_h_s,wk,NEQns,NSTop)
  -    CASE (2)
  -      CALL NUSOL2(XLNzr,COLno,DSLn,ZLN,DIAg,IPErm,R_h_s,wk,NEQns,NSTop)
  -    CASE (3)
  -      CALL NUSOL3(XLNzr,COLno,DSLn,ZLN,DIAg,IPErm,R_h_s,wk,NEQns,NSTop)
  -    CASE (6)
  -      CALL NUSOLX(XLNzr,COLno,DSLn,ZLN,DIAg,IPErm,R_h_s,wk,NEQns,NSTop,NDEg,ndegl)
  -    CASE DEFAULT
  -      CALL NUSOLX(XLNzr,COLno,DSLn,ZLN,DIAg,IPErm,R_h_s,wk,NEQns,NSTop,NDEg,ndegl)
  +    select case( NDEg )
  +    case (1)
  +      call NUSOL1(XLNzr,COLno,DSLn,ZLN,DIAg,IPErm,R_h_s,wk,NEQns,NSTop)
  +    case (2)
  +      call NUSOL2(XLNzr,COLno,DSLn,ZLN,DIAg,IPErm,R_h_s,wk,NEQns,NSTop)
  +    case (3)
  +      call NUSOL3(XLNzr,COLno,DSLn,ZLN,DIAg,IPErm,R_h_s,wk,NEQns,NSTop)
  +    case (6)
  +      call NUSOLX(XLNzr,COLno,DSLn,ZLN,DIAg,IPErm,R_h_s,wk,NEQns,NSTop,NDEg,ndegl)
  +    case DEFAULT
  +      call NUSOLX(XLNzr,COLno,DSLn,ZLN,DIAg,IPErm,R_h_s,wk,NEQns,NSTop,NDEg,ndegl)
       ENDSELECT
   
       STAge = 40
  -    DEALLOCATE (wk)
  -  END SUBROUTINE NUSOL0
  +    deallocate (wk)
  +  end subroutine NUSOL0
   
     !======================================================================!
     !> @brief NUSOL1 performs forward elimination and backward substitution
     !======================================================================!
  -  SUBROUTINE NUSOL1(Xlnzr,Colno,Dsln,Zln,Diag,Iperm,B,Wk,Neqns,Nstop)
  -    IMPLICIT NONE
  -    !------
  -    INTEGER, INTENT(IN):: Neqns
  -    INTEGER, INTENT(IN):: Nstop
  -    INTEGER, INTENT(IN):: Xlnzr(*)
  -    INTEGER, INTENT(IN):: Colno(*)
  -    INTEGER, INTENT(IN):: Iperm(*)
  -    REAL(KIND=8), INTENT(IN):: Zln(*)
  -    REAL(KIND=8), INTENT(IN):: Diag(*)
  -    REAL(KIND=8), INTENT(IN):: Dsln(*)
  -    REAL(KIND=8), INTENT(OUT):: B(*)
  -    REAL(KIND=8), INTENT(OUT):: Wk(*)
  -    !------
  -    INTEGER:: i
  -    INTEGER:: j
  -    INTEGER:: joc
  -    INTEGER:: k
  -    INTEGER:: ke
  -    INTEGER:: ks
  +  subroutine NUSOL1(Xlnzr,Colno,Dsln,Zln,Diag,Iperm,B,Wk,Neqns,Nstop)
  +    implicit none
  +    !------
  +    integer, intent(IN):: Neqns
  +    integer, intent(IN):: Nstop
  +    integer, intent(IN):: Xlnzr(*)
  +    integer, intent(IN):: Colno(*)
  +    integer, intent(IN):: Iperm(*)
  +    real(KIND=8), intent(IN):: Zln(*)
  +    real(KIND=8), intent(IN):: Diag(*)
  +    real(KIND=8), intent(IN):: Dsln(*)
  +    real(KIND=8), intent(OUT):: B(*)
  +    real(KIND=8), intent(OUT):: Wk(*)
  +    !------
  +    integer:: i
  +    integer:: j
  +    integer:: joc
  +    integer:: k
  +    integer:: ke
  +    integer:: ks
   
       ! forward
  -    DO i = 1, Neqns
  +    do i = 1, Neqns
         Wk(i) = B(Iperm(i))
  -    ENDDO
  +    enddo
       joc = 1
  -    DO i = 1, Neqns
  +    do i = 1, Neqns
         ks = Xlnzr(i)
         ke = Xlnzr(i+1) - 1
  -      IF ( ke>=ks ) Wk(i) = Wk(i) - SPDOT2(Wk,Zln,Colno,ks,ke)
  -      IF ( i>Nstop ) THEN
  +      if ( ke>=ks ) Wk(i) = Wk(i) - SPDOT2(Wk,Zln,Colno,ks,ke)
  +      if ( i>Nstop ) then
           Wk(i) = Wk(i) - DDOT(Wk(Nstop),Dsln(joc),i-Nstop)
           joc = joc + i - Nstop
  -      ENDIF
  -    ENDDO
  -    DO i = 1, Neqns
  +      endif
  +    enddo
  +    do i = 1, Neqns
         Wk(i) = Wk(i)*Diag(i)
  -    ENDDO
  +    enddo
       ! back ward
  -    DO i = Neqns, 1, -1
  -      IF ( i>=Nstop ) THEN
  -        DO j = i - 1, Nstop, -1
  +    do i = Neqns, 1, -1
  +      if ( i>=Nstop ) then
  +        do j = i - 1, Nstop, -1
             joc = joc - 1
             Wk(j) = Wk(j) - Wk(i)*Dsln(joc)
  -        ENDDO
  -      ENDIF
  +        enddo
  +      endif
         ks = Xlnzr(i)
         ke = Xlnzr(i+1) - 1
  -      IF ( ke>=ks ) THEN
  -        DO k = ks, ke
  +      if ( ke>=ks ) then
  +        do k = ks, ke
             j = Colno(k)
             Wk(j) = Wk(j) - Wk(i)*Zln(k)
  -        ENDDO
  -      ENDIF
  -    ENDDO
  +        enddo
  +      endif
  +    enddo
       ! permutaion
  -    DO i = 1, Neqns
  +    do i = 1, Neqns
         B(Iperm(i)) = Wk(i)
  -    ENDDO
  -  END SUBROUTINE NUSOL1
  +    enddo
  +  end subroutine NUSOL1
   
     !======================================================================!
     !> @brief NUSOL2 performs forward elimination and backward substitution
     !======================================================================!
  -  SUBROUTINE NUSOL2(Xlnzr,Colno,Dsln,Zln,Diag,Iperm,B,Wk,Neqns,Nstop)
  -    IMPLICIT NONE
  -    !------
  -    INTEGER, INTENT(IN):: Neqns
  -    INTEGER, INTENT(IN):: Nstop
  -    INTEGER, INTENT(IN):: Xlnzr(*)
  -    INTEGER, INTENT(IN):: Colno(*)
  -    INTEGER, INTENT(IN):: Iperm(*)
  -    REAL(KIND=8), INTENT(IN):: Zln(4,*)
  -    REAL(KIND=8), INTENT(IN):: Diag(3,*)
  -    REAL(KIND=8), INTENT(IN):: Dsln(4,*)
  -    REAL(KIND=8), INTENT(OUT):: B(2,*)
  -    REAL(KIND=8), INTENT(OUT):: Wk(2,*)
  -    !------
  -    INTEGER:: i
  -    INTEGER:: j
  -    INTEGER:: joc
  -    INTEGER:: k
  -    INTEGER:: ke
  -    INTEGER:: ks
  +  subroutine NUSOL2(Xlnzr,Colno,Dsln,Zln,Diag,Iperm,B,Wk,Neqns,Nstop)
  +    implicit none
  +    !------
  +    integer, intent(IN):: Neqns
  +    integer, intent(IN):: Nstop
  +    integer, intent(IN):: Xlnzr(*)
  +    integer, intent(IN):: Colno(*)
  +    integer, intent(IN):: Iperm(*)
  +    real(KIND=8), intent(IN):: Zln(4,*)
  +    real(KIND=8), intent(IN):: Diag(3,*)
  +    real(KIND=8), intent(IN):: Dsln(4,*)
  +    real(KIND=8), intent(OUT):: B(2,*)
  +    real(KIND=8), intent(OUT):: Wk(2,*)
  +    !------
  +    integer:: i
  +    integer:: j
  +    integer:: joc
  +    integer:: k
  +    integer:: ke
  +    integer:: ks
   
       ! forward
  -    DO i = 1, Neqns
  +    do i = 1, Neqns
         Wk(1,i) = B(1,Iperm(i))
         Wk(2,i) = B(2,Iperm(i))
  -    ENDDO
  +    enddo
       joc = 1
  -    DO i = 1, Neqns
  +    do i = 1, Neqns
         ks = Xlnzr(i)
         ke = Xlnzr(i+1) - 1
  -      IF ( ke>=ks ) CALL S2PDOT(Wk(1,i),Wk,Zln,Colno,ks,ke)
  -      IF ( i>Nstop ) THEN
  -        CALL D2SDOT(Wk(1,i),Wk(1,Nstop),Dsln(1,joc),i-Nstop)
  +      if ( ke>=ks ) call S2PDOT(Wk(1,i),Wk,Zln,Colno,ks,ke)
  +      if ( i>Nstop ) then
  +        call D2SDOT(Wk(1,i),Wk(1,Nstop),Dsln(1,joc),i-Nstop)
           joc = joc + i - Nstop
  -      ENDIF
  -    ENDDO
  -    DO i = 1, Neqns
  +      endif
  +    enddo
  +    do i = 1, Neqns
         Wk(2,i) = Wk(2,i) - Wk(1,i)*Diag(2,i)
         Wk(1,i) = Wk(1,i)*Diag(1,i)
         Wk(2,i) = Wk(2,i)*Diag(3,i)
         Wk(1,i) = Wk(1,i) - Wk(2,i)*Diag(2,i)
  -    ENDDO
  +    enddo
       ! back ward
  -    DO i = Neqns, 1, -1
  -      IF ( i>=Nstop ) THEN
  -        DO j = i - 1, Nstop, -1
  +    do i = Neqns, 1, -1
  +      if ( i>=Nstop ) then
  +        do j = i - 1, Nstop, -1
             joc = joc - 1
             Wk(1,j) = Wk(1,j) - Wk(1,i)*Dsln(1,joc) - Wk(2,i)*Dsln(2,joc)
             Wk(2,j) = Wk(2,j) - Wk(1,i)*Dsln(3,joc) - Wk(2,i)*Dsln(4,joc)
  -        ENDDO
  -      ENDIF
  +        enddo
  +      endif
         ks = Xlnzr(i)
         ke = Xlnzr(i+1) - 1
  -      IF ( ke>=ks ) THEN
  -        DO k = ks, ke
  +      if ( ke>=ks ) then
  +        do k = ks, ke
             j = Colno(k)
             Wk(1,j) = Wk(1,j) - Wk(1,i)*Zln(1,k) - Wk(2,i)*Zln(2,k)
             Wk(2,j) = Wk(2,j) - Wk(1,i)*Zln(3,k) - Wk(2,i)*Zln(4,k)
  -        ENDDO
  -      ENDIF
  -    ENDDO
  +        enddo
  +      endif
  +    enddo
       ! permutaion
  -    DO i = 1, Neqns
  +    do i = 1, Neqns
         B(1,Iperm(i)) = Wk(1,i)
         B(2,Iperm(i)) = Wk(2,i)
  -    ENDDO
  -  END SUBROUTINE NUSOL2
  +    enddo
  +  end subroutine NUSOL2
   
     !======================================================================!
     !> @brief NUSOL3 performs forward elimination and backward substitution
     !======================================================================!
  -  SUBROUTINE NUSOL3(Xlnzr,Colno,Dsln,Zln,Diag,Iperm,B,Wk,Neqns,Nstop)
  -    IMPLICIT NONE
  -    !------
  -    INTEGER, INTENT(IN):: Neqns
  -    INTEGER, INTENT(IN):: Nstop
  -    INTEGER, INTENT(IN):: Xlnzr(*)
  -    INTEGER, INTENT(IN):: Colno(*)
  -    INTEGER, INTENT(IN):: Iperm(*)
  -    REAL(KIND=8), INTENT(IN):: Zln(9,*)
  -    REAL(KIND=8), INTENT(IN):: Diag(6,*)
  -    REAL(KIND=8), INTENT(IN):: Dsln(9,*)
  -    REAL(KIND=8), INTENT(OUT):: B(3,*)
  -    REAL(KIND=8), INTENT(OUT):: Wk(3,*)
  -    !------
  -    INTEGER:: i
  -    INTEGER:: j
  -    INTEGER:: joc
  -    INTEGER:: k
  -    INTEGER:: ke
  -    INTEGER:: ks
  +  subroutine NUSOL3(Xlnzr,Colno,Dsln,Zln,Diag,Iperm,B,Wk,Neqns,Nstop)
  +    implicit none
  +    !------
  +    integer, intent(IN):: Neqns
  +    integer, intent(IN):: Nstop
  +    integer, intent(IN):: Xlnzr(*)
  +    integer, intent(IN):: Colno(*)
  +    integer, intent(IN):: Iperm(*)
  +    real(KIND=8), intent(IN):: Zln(9,*)
  +    real(KIND=8), intent(IN):: Diag(6,*)
  +    real(KIND=8), intent(IN):: Dsln(9,*)
  +    real(KIND=8), intent(OUT):: B(3,*)
  +    real(KIND=8), intent(OUT):: Wk(3,*)
  +    !------
  +    integer:: i
  +    integer:: j
  +    integer:: joc
  +    integer:: k
  +    integer:: ke
  +    integer:: ks
   
       ! forward
  -    DO i = 1, Neqns
  +    do i = 1, Neqns
         Wk(1,i) = B(1,Iperm(i))
         Wk(2,i) = B(2,Iperm(i))
         Wk(3,i) = B(3,Iperm(i))
  -    ENDDO
  +    enddo
       joc = 1
  -    DO i = 1, Neqns
  +    do i = 1, Neqns
         ks = Xlnzr(i)
         ke = Xlnzr(i+1) - 1
  -      IF ( ke>=ks ) CALL S3PDOT(Wk(1,i),Wk,Zln,Colno,ks,ke)
  -      IF ( i>Nstop ) THEN
  -        CALL D3SDOT(Wk(1,i),Wk(1,Nstop),Dsln(1,joc),i-Nstop)
  +      if ( ke>=ks ) call S3PDOT(Wk(1,i),Wk,Zln,Colno,ks,ke)
  +      if ( i>Nstop ) then
  +        call D3SDOT(Wk(1,i),Wk(1,Nstop),Dsln(1,joc),i-Nstop)
           joc = joc + i - Nstop
  -      ENDIF
  -    ENDDO
  -    DO i = 1, Neqns
  +      endif
  +    enddo
  +    do i = 1, Neqns
         Wk(2,i) = Wk(2,i) - Wk(1,i)*Diag(2,i)
         Wk(3,i) = Wk(3,i) - Wk(1,i)*Diag(4,i) - Wk(2,i)*Diag(5,i)
         Wk(1,i) = Wk(1,i)*Diag(1,i)
  
positive.code:   !                     irr=1          is a bottom node then rotation is
    !                                    performed
    !======================================================================!
    SUBROUTINE ROTATE(Xadj,Adjncy,Invp,Iperm,Parent,Btree,Izz,Neqns,Anc,Adjt,Irr)
      IMPLICIT NONE
      !------
      INTEGER, INTENT(IN):: Izz
      INTEGER, INTENT(IN):: Neqns
      INTEGER, INTENT(IN):: Xadj(*)
      INTEGER, INTENT(IN):: Adjncy(*)
      INTEGER, INTENT(IN):: Parent(*)
      INTEGER, INTENT(IN):: Btree(2,*)
      INTEGER, INTENT(OUT):: Irr
      INTEGER, INTENT(OUT):: Invp(*)
      INTEGER, INTENT(OUT):: Iperm(*)
      INTEGER, INTENT(OUT):: Anc(*)
      INTEGER, INTENT(OUT):: Adjt(*)
      !------
      INTEGER:: i
      INTEGER:: iy
      INTEGER:: izzz
      INTEGER:: joc
      INTEGER:: k
      INTEGER:: l
      INTEGER:: ll
      INTEGER:: locc
      INTEGER:: nanc
  
      IF ( Izz==0 ) THEN
        Irr = 0
        RETURN
      ENDIF
      izzz = Invp(Izz)
  
      IF ( Btree(1,izzz)/=0 ) Irr = 0
      Irr = 1
      !
      !  ancestors of izzz
      !
      nanc = 0
      joc = izzz
      DO
        nanc = nanc + 1
        Anc(nanc) = joc
        joc = Parent(joc)
        IF ( joc==0 ) THEN
          !
          !  to find the eligible node from ancestors of izz
          !
          l = 1
          EXIT
        ENDIF
      ENDDO
  
  100 CONTINUE
      Adjt(1:Neqns) = 0
      locc = Anc(l)
      DO
        joc = locc
        locc = Btree(1,joc)
        IF ( locc==0 ) THEN
          DO
            Adjt(Invp(Adjncy(Xadj(Iperm(joc)):Xadj(Iperm(joc)+1) - 1))) = 1
            IF ( joc>=Anc(l) ) THEN
              DO ll = l + 1, nanc
                IF ( Adjt(Anc(ll))==0 ) THEN
                  l = l + 1
                  GOTO 100
                ENDIF
              ENDDO
              IF ( l==1 ) THEN
                !
                ! izz can be numbered last
                !
                k = 0
                DO i = 1, Neqns
                  IF ( i/=izzz ) THEN
                    k = k + 1
                    Invp(Iperm(i)) = k
                  ENDIF
                ENDDO
                Invp(Iperm(izzz)) = Neqns
              ELSE
                !
                !  anc(l-1) is the eligible node
                !
  
negative.code:   !      (o)
    !          iv       communication array
    !======================================================================!
    subroutine STAIJ1(Isw,I,J,Aij,Ir)
      implicit none
      !------
      integer, intent(IN):: I
      integer, intent(IN):: Isw
      integer, intent(IN):: J
      real(KIND=8), intent(IN):: Aij(NDEg*NDEg)
      integer, intent(OUT):: Ir
      !------
      integer:: ndeg2
      integer:: ndeg2l
  
      Ir = 0
      ndeg2 = NDEg*NDEg
      ndeg2l = NDEg*(NDEg+1)/2
      if ( STAge==30 ) write (6,*) 'warning a matrix was build up '//'but never solved.'
      if ( STAge==10 ) then
        allocate (DIAg(NEQns*ndeg2l),STAT=IERror)
        RALoc = RALoc + NEQns*ndeg2l
        allocate (ZLN(LEN_colno*ndeg2),STAT=IERror)
  
        RALoc = RALoc + LEN_colno*ndeg2
        allocate (DSLn(LEN_dsln*ndeg2),STAT=IERror)
  
        if ( IERror/=0 ) stop "Allocation error dsln"
  
        RALoc = RALoc + LEN_dsln*ndeg2
      endif
      if ( STAge/=20 ) then
        !
        ! for diagonal
        !
  