2
C Pack real-valued input buffer into a GA. Determines size of
3
C buffer from the size of the GA (must be square matrix).
5
subroutine pack_buffer2ga_dbl (buff, g_a)
10
#include "mafdecls.fh"
14
double precision, intent(in) :: buff(*)
17
integer, intent(in) :: g_a
20
character(*), parameter :: pname = "pack_buffer2ga_dbl: "
25
integer dtype, dim1, dim2
31
C Check the output GA (input 2).
33
call ga_check_handle (g_a,
34
$ "second argument of "//pname//"not a valid GA")
35
call ga_inquire (g_a, dtype, dim1, dim2)
38
$ call errquit (pname//"dim1 must equal dim2", 0, 0)
41
if (dtype .ne. mt_dbl)
42
$ call errquit (pname//"expecting real GA", 0, 0)
49
ok = ok.and.ma_push_get(mt_dbl, n, "tmp buffer", ltmp,itmp)
50
if (.not.ok) call errquit (pname//"alloc failed", 0, MA_ERR)
54
C Pack into GA. Note pointer vs fortran indexing.
58
dbl_mb(itmp + j - 1) = buff(n*(i-1) + j)
60
call ga_put (g_a, 1, n, i, i, dbl_mb(itmp), n)
67
if (.not.ma_pop_stack(ltmp))
68
$ call errquit (pname//"failed to pop stack", 0, MA_ERR)
75
C====================================================================
77
C Pack complex-valued input buffer into a GA. Determines size of
78
C buffer from the size of the GA (must be square matrix).
80
subroutine pack_buffer2ga_dcpl (buff, g_a)
85
#include "mafdecls.fh"
90
double complex, intent(in) :: buff(*)
94
integer, intent(in) :: g_a
98
character(*), parameter :: pname = "pack_buffer2ga_dcpl: "
103
integer dtype, dim1, dim2
109
C Check the output GA (input 2).
111
call ga_check_handle (g_a,
112
$ "second argument of "//pname//"not a valid GA")
113
call ga_inquire (g_a, dtype, dim1, dim2)
116
$ call errquit (pname//"dim1 must equal dim2", 0, 0)
119
if (dtype .ne. mt_dcpl)
120
$ call errquit (pname//"expecting complex GA", 0, 0)
127
ok = ok.and.ma_push_get(mt_dcpl, n, "tmp buffer", ltmp,itmp)
128
if (.not.ok) call errquit (pname//"alloc failed", 0, MA_ERR)
132
C Pack into GA. Note pointer vs fortran indexing.
136
dcpl_mb(itmp + j - 1) = buff(n*(i-1) + j)
138
call ga_put (g_a, 1, n, i, i, dcpl_mb(itmp), n)
145
if (.not.ma_pop_stack(ltmp))
146
$ call errquit (pname//"failed to pop stack", 0, MA_ERR)