00001 !----------------------------------------------------------------------- 00002 ! Copyright 2006-2010, NEC Europe Ltd., London, UK. 00003 ! All rights reserved. Use is subject to OASIS4 license terms. 00004 !----------------------------------------------------------------------- 00005 !BOP 00006 ! 00007 ! !ROUTINE: PSMILe_Copy_subarray_3d_real 00008 ! 00009 ! !INTERFACE: 00010 00011 subroutine psmile_copy_subarray_3d_real (dest_vector, size, & 00012 darray, idlow, idhigh, jdlow, jdhigh, kdlow, kdhigh, & 00013 sub, ierror) 00014 ! 00015 ! !USES: 00016 ! 00017 use PRISM_constants 00018 ! 00019 use PSMILe, dummy_interface => PSMILe_Copy_subarray_3d_real 00020 00021 implicit none 00022 ! 00023 ! !INPUT PARAMETERS: 00024 ! 00025 integer(kind=int64), Intent (In) :: size 00026 00027 ! Size (length) of destination vector "dest" 00028 00029 integer, Intent (In) :: idlow 00030 00031 ! Lowest first dimension of array "iarray" 00032 00033 integer, Intent (In) :: idhigh 00034 00035 ! Highest first dimension of array "iarray" 00036 00037 integer, Intent (In) :: jdlow 00038 00039 ! Lowest second dimension of array "iarray" 00040 00041 integer, Intent (In) :: jdhigh 00042 00043 ! Highest second dimension of array "iarray" 00044 00045 integer, Intent (In) :: kdlow 00046 00047 ! Lowest third dimension of array "iarray" 00048 00049 integer, Intent (In) :: kdhigh 00050 00051 ! Highest third dimension of array "iarray" 00052 00053 real, Intent (In) :: darray (idlow:idhigh, 00054 jdlow:jdhigh, 00055 kdlow:kdhigh) 00056 00057 ! Array containg the sub-array to be copied 00058 00059 integer, Intent (In) :: sub (1:2, 1:3) 00060 ! 00061 ! Specifies the sub-array to be copied with 00062 00063 ! sub (1, 1) = Lowest first index of sub-array 00064 ! sub (2, 1) = Highest first index of sub-array 00065 ! sub (1, 2) = Lowest second index of sub-array 00066 ! sub (2, 2) = Highest second index of sub-array 00067 ! sub (1, 3) = Lowest third index of sub-array 00068 ! sub (2, 3) = Highest third index of sub-array 00069 ! 00070 ! !OUTPUT PARAMETERS: 00071 ! 00072 real, Intent (Out) :: dest_vector (size) 00073 00074 ! Destintation vector 00075 00076 integer, Intent (Out) :: ierror 00077 00078 ! Returns the error code of PSMILe_Copy_subarray_3d_real; 00079 ! ierror = 0 : No error 00080 ! ierror > 0 : Severe error 00081 ! 00082 ! !LOCAL VARIABLES 00083 ! 00084 integer :: i, j, k, leni 00085 integer(kind=int64) :: ip 00086 ! 00087 ! !DESCRIPTION: 00088 ! 00089 ! Subroutine "PSMILe_Copy_subarray_3d_real" copies the subarray\\ 00090 ! 00091 ! darray (sub(1,1):sub(2,1), sub(1,2):sub(2,2), sub (1,3):sub(2,3))\\ 00092 ! 00093 ! into the 1-dimensional destination vector "dest_vector".\\ 00094 ! 00095 ! !REVISION HISTORY: 00096 ! 00097 ! Date Programmer Description 00098 ! ---------- ---------- ----------- 00099 ! 01.12.03 H. Ritzdorf created 00100 ! 00101 !EOP 00102 !---------------------------------------------------------------------- 00103 ! 00104 ! $Id: psmile_copy_subarray_3d_real.F90 2325 2010-04-21 15:00:07Z valcke $ 00105 ! $Author: valcke $ 00106 Character(len=len_cvs_string), save :: mycvs = 00107 '$Id: psmile_copy_subarray_3d_real.F90 2325 2010-04-21 15:00:07Z valcke $' 00108 ! 00109 !---------------------------------------------------------------------- 00110 ! 00111 ! Initialization 00112 ! 00113 ! ??? waere es moeglich dest_array als 00114 ! dest_array (sub(1,1):sub(2,1), sub(1,2):sub(2,2), sub (1,3):sub(2,3)) 00115 ! zu deklariren und dann 00116 ! 00117 ! dest_array = darray (sub(1,1):sub(2,1), sub(1,2):sub(2,2), sub (1,3):sub(2,3) 00118 ! asuzufuehren ? 00119 ! 00120 ! 00121 ierror = 0 00122 ! 00123 ip = 1 00124 ! 00125 leni = sub(2,1) - sub (1,1) + 1 00126 ! 00127 do k = sub (1, 3), sub (2, 3) 00128 do j = sub (1, 2), sub (2, 2) 00129 !cdir vector 00130 do i = sub (1, 1), sub (2, 1) 00131 dest_vector (ip+(i-sub(1,1))) = darray (i, j, k) 00132 enddo 00133 00134 ip = ip + leni 00135 enddo 00136 enddo 00137 ! 00138 end subroutine PSMILe_Copy_subarray_3d_real
1.6.1