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_double 00008 ! 00009 ! !INTERFACE: 00010 00011 subroutine psmile_copy_subarray_3d_double (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_double 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 double precision, 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 double precision, 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_double; 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_double" copies the subarray\\ 00090 ! darray (sub(1,1):sub(2,1), sub(1,2):sub(2,2), sub (1,3):sub(2,3))\\ 00091 ! into the 1-dimensional destination vector "dest_vector". 00092 ! 00093 ! !REVISION HISTORY: 00094 ! 00095 ! Date Programmer Description 00096 ! ---------- ---------- ----------- 00097 ! 01.12.03 H. Ritzdorf created 00098 ! 00099 !EOP 00100 !---------------------------------------------------------------------- 00101 ! 00102 ! $Id: psmile_copy_subarray_3d_double.F90 2325 2010-04-21 15:00:07Z valcke $ 00103 ! $Author: valcke $ 00104 ! 00105 Character(len=len_cvs_string), save :: mycvs = 00106 '$Id: psmile_copy_subarray_3d_double.F90 2325 2010-04-21 15:00:07Z valcke $' 00107 ! 00108 !---------------------------------------------------------------------- 00109 ! 00110 ! Initialization 00111 ! 00112 ! ??? waere es moeglich dest_array als 00113 ! dest_array (sub(1,1):sub(2,1), sub(1,2):sub(2,2), sub (1,3):sub(2,3)) 00114 ! zu deklariren und dann 00115 ! 00116 ! dest_array = darray (sub(1,1):sub(2,1), sub(1,2):sub(2,2), sub (1,3):sub(2,3) 00117 ! asuzufuehren ? 00118 ! 00119 ! 00120 ierror = 0 00121 ! 00122 ip = 1 00123 ! 00124 leni = sub(2,1) - sub (1,1) + 1 00125 ! 00126 do k = sub (1, 3), sub (2, 3) 00127 do j = sub (1, 2), sub (2, 2) 00128 !cdir vector 00129 do i = sub (1, 1), sub (2, 1) 00130 dest_vector (ip+(i-sub(1,1))) = darray (i, j, k) 00131 enddo 00132 00133 ip = ip + leni 00134 enddo 00135 enddo 00136 ! 00137 end subroutine PSMILe_Copy_subarray_3d_double
1.6.1