diagB_eq_diagA_Full.F

c**********************************************************************
#include "author.inc"
c*    $Id: diagB_eq_diagA_Full.F,v 1.1 1995/10/10 03:11:03 turner Exp $
c*
c*    Copies the diagonal of one matrix into the diagonal of another,
c*    for matrices stored in full format.
c*
c*    <PARAMETER LIST>
c*
c*     Input:
c*      idim_a - leading dimension of a
c*      idim_b - leading dimension of b
c*      n - number of rows/columns
c*      a - matrix to be copied
c*
c*     Output:
c*      b - destination matrix
c*      status - return status
c*
#include "copyright.inc"
c**********************************************************************
      subroutine JT_diagB_eq_diagA_Full (idim_a, idim_b, n, a, b,
     &           status)
      implicit none
c
c ... Input:
      integer idim_a, idim_b, n
      real a(idim_a,n)
c
c ... Output:
      integer status
      real b(idim_b,n)
c
c ... Local:
      integer i
c
      do i=1,n
       b(i,i) = a(i,i)
      enddo
c
      status = 0
      return
      end
c**********************************************************************
#include "author.inc"
c*
c*    Copies the inverse of the diagonal of one matrix into the
c*    diagonal of another.
c*
c*    WARNING: This routine does not check to ensure that 
c*             a(i,i) /= 0.
c*
c*    <PARAMETER LIST>
c*
c*     Input:
c*      idim_a - leading dimension of a
c*      idim_b - leading dimension of b
c*      n - number of rows/columns
c*      a - matrix to be copied
c*
c*     Output:
c*      b - destination matrix
c*      status - return status
c*
#include "copyright.inc"
c**********************************************************************
      subroutine JT_diagB_eq_invdiagA_Full (idim_a, idim_b, n, a, b,
     &           status)
      implicit none
c
c ... Input:
      integer idim_a, idim_b, n
      real a(idim_a,n)
c
c ... Output:
      integer status
      real b(idim_b,n)
c
c ... Local:
      integer i
      real one
      parameter (one=1.0d0)
c
      do i=1,n
       b(i,i) = one / a(i,i)
      enddo
c
      status = 0
      return
      end