File: C:\NOAA\NEMS_11731\src\chem\gocart\src\GMAO_Shared\MAPL_Base\write_parallel.H
1 ! $Id: write_parallel.H,v 1.3 2009/04/29 16:01:51 wputman Exp $
2
3 #ifdef NAME_
4 #undef NAME_
5 #endif
6
7 #define NAME_ WRITE_PARALLEL_
8
9 #include "overload.macro"
10
11
12 subroutine SUB_ ( data, UNIT, ARRDES, format, RC)
13
14 #if (VARTYPE_ > 0)
15 TYPE_(kind=EKIND_ ), intent(in ) :: data DIMENSIONS_
16 #else
17 character(LEN=*), intent(in ) :: data DIMENSIONS_
18 #endif
19 integer, intent(in ), optional :: UNIT
20 type(ArrDescr), intent(INOUT), optional :: ARRDES
21 character(len=*), intent(in ), optional :: format
22 integer , intent( out), optional :: RC
23
24 character(len=ESMF_MAXSTR) :: FORMATTED
25 character(len=ESMF_MAXSTR) :: IAM='WRITE_PARALLEL'
26 integer :: recl, status
27
28 if(present(arrdes)) then
29 if (MAPL_AM_I_ROOT()) then
30 if(arrdes%offset>=0) then
31 call MPI_FILE_SEEK(UNIT, arrdes%offset, MPI_SEEK_SET, STATUS)
32 VERIFY_(STATUS)
33 endif
34
35 #if (RANK_ == 0)
36 #if (VARTYPE_ == 0)
37 recl = len(data)*4
38 call MPI_FILE_WRITE(UNIT, recl, 1, MPI_INTEGER, MPI_STATUS_IGNORE, STATUS)
39 call MPI_FILE_WRITE(UNIT, data, len(data), MPITYPE_ , MPI_STATUS_IGNORE, STATUS)
40 call MPI_FILE_WRITE(UNIT, recl, 1, MPI_INTEGER, MPI_STATUS_IGNORE, STATUS)
41 #ifdef DEBUG_MPIIO
42 print*, arrdes%offset, recl, arrdes%offset + len(data)*4 + 8
43 #endif
44 #else
45 recl = 1*EKIND_
46 call MPI_FILE_WRITE(UNIT, recl, 1, MPI_INTEGER, MPI_STATUS_IGNORE, STATUS)
47 call MPI_FILE_WRITE(UNIT, data, 1, MPITYPE_, MPI_STATUS_IGNORE, STATUS)
48 call MPI_FILE_WRITE(UNIT, recl, 1, MPI_INTEGER, MPI_STATUS_IGNORE, STATUS)
49 #ifdef DEBUG_MPIIO
50 print*, arrdes%offset, recl, arrdes%offset + 1*EKIND_ + 8
51 #endif
52 #endif
53 #else
54 recl = size(data)*EKIND_
55 call MPI_FILE_WRITE(UNIT, recl, 1, MPI_INTEGER, MPI_STATUS_IGNORE, STATUS)
56 call MPI_FILE_WRITE(UNIT, data, size(data), MPITYPE_, MPI_STATUS_IGNORE, STATUS)
57 call MPI_FILE_WRITE(UNIT, recl, 1, MPI_INTEGER, MPI_STATUS_IGNORE, STATUS)
58 #ifdef DEBUG_MPIIO
59 print*, arrdes%offset, recl, arrdes%offset + size(data)*EKIND_ + 8
60 #endif
61 #endif
62 VERIFY_(STATUS)
63
64 endif
65
66 #if (RANK_ == 0)
67 #if (VARTYPE_ == 0)
68 arrdes%offset = arrdes%offset + len(data)*4 + 8
69 #else
70 arrdes%offset = arrdes%offset + 1*EKIND_ + 8
71 #endif
72 #else
73 arrdes%offset = arrdes%offset + size(data)*EKIND_ + 8
74 #endif
75
76 RETURN_(ESMF_SUCCESS)
77 endif
78
79 if (present(unit)) then
80 if (unit == UNDEF) then
81 RETURN_(ESMF_SUCCESS)
82 endif
83 if(unit < 0) then
84
85 #if (RANK_ > 2 || VARTYPE_ <= 0)
86
87 ASSERT_(.FALSE.)
88
89 #else
90
91 ASSERT_(-UNIT<=LAST_UNIT)
92 munit => MEM_units(-unit)
93 munit%prevrec = munit%prevrec + 1
94
95 if(.not.associated(munit%Records)) then
96 allocate(Rec(16),stat=status)
97 munit%Records => REC
98 VERIFY_(STATUS)
99 elseif(size(munit%Records)< munit%prevrec) then
100 allocate(REC(munit%prevrec*2),stat=status)
101 VERIFY_(STATUS)
102 REC(:munit%prevrec-1) = munit%Records
103 deallocate(munit%Records)
104 munit%Records => REC
105 endif
106
107 #if (RANK_ == 0)
108 call dealloc_(munit%Records(munit%prevrec),rc=status)
109 VERIFY_(STATUS)
110 #endif
111
112 #if (RANK_ == 1)
113 call alloc_(munit%Records(munit%prevrec),TKR_,size(data,1),rc=status)
114 VERIFY_(STATUS)
115 #endif
116
117 #if (RANK_ == 2)
118 call alloc_(munit%Records(munit%prevrec),TKR_,size(data,1),size(data,2),rc=status)
119 VERIFY_(STATUS)
120 #endif
121
122 munit%Records(munit%prevrec)%TKR_ = data
123
124 #endif
125 else ! unit is > 0
126 if (MAPL_AM_I_ROOT()) then
127 inquire(unit=UNIT, formatted=FORMATTED)
128 if (FORMATTED == "YES") then
129 if (present(format)) then; write(UNIT, format) data
130 else; write(UNIT, * ) data
131 end if
132 elseif(FORMATTED == "NO") then; write(UNIT ) data
133 end if
134 endif
135 end if
136 else
137
138 if (MAPL_AM_I_ROOT()) then
139 if (present(format)) then; write(*, format) data
140 else; write(*, *) data
141 end if
142 end if
143 end if
144
145 RETURN_(ESMF_SUCCESS)
146
147 end subroutine SUB_
148
149 !---------------------------
150 #undef NAME_
151
152 #undef DIMENSIONS_
153 #undef RANK_
154 #undef VARTYPE_
155