Oasis3 4.0.2
|
00001 MODULE memoir 00002 C**** 00003 C ***************************** 00004 C * OASIS ROUTINE - LEVEL 3 * 00005 C * ------------- ------- * 00006 C ***************************** 00007 C 00008 C**** *memoir* - F90 interface for dynamic allocation in FSCINT 00009 C 00010 C Purpose: 00011 C ------- 00012 C Handle dynamic allocation in FSCINT 00013 C 00014 C** Interface: 00015 C --------- 00016 C *CALL* *memoir(r-i)(pw,koff,ksize,koldsize) 00017 C 00018 C Input: 00019 C ----- 00020 C pw : array to be allocated 00021 C ksize : new size to be allocated 00022 C koldsize : old size of allocation 00023 C 00024 C Output: 00025 C ------ 00026 C koff : status flag 00027 C 00028 C Workspace: 00029 C --------- 00030 C None 00031 C 00032 C Externals: 00033 C --------- 00034 C None 00035 C 00036 C Reference: 00037 C --------- 00038 C This F90 module handles dynamic allocation within FSCINT. 00039 C It deals with both INTEGER and REAL memory allocation. 00040 C It has been tested on a variety of platforms (SGI, VPP, T3E, C90) 00041 C and is truly portable. The compilation step may vary across 00042 C platforms (see OASIS documentation 2.2). The module has been 00043 C written with fixed format and should then be named with suffix .f 00044 C 00045 C History: 00046 C ------- 00047 C Version Programmer Date Description 00048 C ------- ---------- ---- ----------- 00049 C 2.2 A. Piacentini 97/09/15 Created 00050 C 2.3 A. Piacentini 98/10/01 Modified: Bug corrected in case 00051 C of reallocation 00052 C 00053 C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 00054 C* ------------------------------------------------------------------ 00055 C 00056 C* ---------------------------- Poema verses ---------------------------- 00057 C 00058 C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 00059 C 00060 C* Block interface 00061 C 00062 INTERFACE memoirh 00063 MODULE PROCEDURE memoirr,memoiri 00064 END INTERFACE 00065 C 00066 CONTAINS 00067 C 00068 C* Real allocation 00069 C 00070 SUBROUTINE memoirr(pw,koff,ksize,koldsize) 00071 C 00072 USE mod_kinds_oasis 00073 REAL(kind=ip_realwp_p), DIMENSION(:), POINTER :: pw 00074 INTEGER (kind=ip_intwp_p) :: koff 00075 INTEGER (kind=ip_intwp_p) :: ksize 00076 INTEGER (kind=ip_intwp_p) :: koldsize 00077 C 00078 REAL(kind=ip_realwp_p), DIMENSION(:), POINTER :: aw 00079 INTEGER (kind=ip_intwp_p) :: ierr 00080 C 00081 C PRINT *,'memoirR ksize ',ksize 00082 C 00083 IF (ksize > 0) THEN 00084 IF (koldsize > 0) THEN 00085 allocate(aw(ksize),stat=ierr) 00086 C PRINT *,'ierr= ',ierr 00087 IF(.NOT. associated(aw)) PRINT *,'memoirR Something Wrong' 00088 koff=1 00089 aw(1:koldsize)=pw 00090 deallocate(pw,stat=ierr) 00091 C PRINT *,'memoirR dealloc of old pw ierr= ',ierr 00092 pw=>aw 00093 ELSE 00094 allocate(pw(ksize),stat=ierr) 00095 C PRINT *,'ierr= ',ierr 00096 IF(.NOT. associated(pw)) PRINT *,'memoirR Something Wrong' 00097 C 00098 C PRINT *,'memoirR allocated' 00099 C 00100 koff=1 00101 ENDIF 00102 ELSE 00103 IF(associated(pw)) THEN 00104 deallocate(pw,stat=ierr) 00105 C PRINT *,'memoirR dealloc ierr= ',ierr 00106 ELSE 00107 STOP 'error in memoirR deallocation' 00108 END IF 00109 C 00110 C PRINT *,'memoirR deallocated' 00111 C 00112 ENDIF 00113 C 00114 END SUBROUTINE memoirr 00115 C 00116 C* Integer allocation 00117 C 00118 SUBROUTINE memoiri(kw,koff,ksize,koldsize) 00119 C 00120 USE mod_kinds_oasis 00121 INTEGER (kind=ip_intwp_p) , DIMENSION(:), POINTER :: kw 00122 INTEGER (kind=ip_intwp_p) :: koff 00123 INTEGER (kind=ip_intwp_p) :: ksize 00124 INTEGER (kind=ip_intwp_p) :: koldsize 00125 C 00126 INTEGER (kind=ip_intwp_p) , DIMENSION(:), POINTER :: iw 00127 INTEGER (kind=ip_intwp_p) :: ierr 00128 C 00129 C PRINT *,'memoirI ksize ',ksize 00130 C 00131 IF (ksize > 0) THEN 00132 IF (koldsize > 0) THEN 00133 allocate(iw(ksize),stat=ierr) 00134 C PRINT *,'ierr= ',ierr 00135 IF(.NOT. associated(iw)) PRINT *,'memoirI Something Wrong' 00136 koff=1 00137 iw(1:koldsize)=kw 00138 deallocate(kw,stat=ierr) 00139 C PRINT *,'memoirI dealloc of old kw ierr= ',ierr 00140 kw=>iw 00141 ELSE 00142 allocate(kw(ksize),stat=ierr) 00143 C PRINT *,'ierr= ',ierr 00144 IF(.NOT. associated(kw)) PRINT *,'memoirI Something Wrong' 00145 C 00146 C PRINT *,'memoirI allocated' 00147 C 00148 koff=1 00149 ENDIF 00150 ELSE 00151 IF(associated(kw)) THEN 00152 deallocate(kw,stat=ierr) 00153 C PRINT *,'memoirI dealloc ierr= ',ierr 00154 ELSE 00155 STOP 'error in memoirI deallocation' 00156 END IF 00157 C 00158 C PRINT *,'memoirI deallocated' 00159 C 00160 ENDIF 00161 C 00162 END SUBROUTINE memoiri 00163 C 00164 END MODULE memoir 00165 00166 00167 00168