| 1 | |
|---|
| 2 | !> System type methods |
|---|
| 3 | |
|---|
| 4 | MODULE mod_oasis_sys |
|---|
| 5 | |
|---|
| 6 | USE mod_oasis_kinds |
|---|
| 7 | USE mod_oasis_data |
|---|
| 8 | |
|---|
| 9 | IMPLICIT NONE |
|---|
| 10 | |
|---|
| 11 | character(len=*),parameter,public :: astr = ' ABORT: ' ! abort string |
|---|
| 12 | character(len=*),parameter,public :: estr = ' ERROR: ' ! error string |
|---|
| 13 | character(len=*),parameter,public :: wstr = ' WARNING: ' ! warning string |
|---|
| 14 | |
|---|
| 15 | private |
|---|
| 16 | |
|---|
| 17 | public oasis_abort |
|---|
| 18 | public oasis_flush |
|---|
| 19 | public oasis_unitsetmin |
|---|
| 20 | public oasis_unitsetmax |
|---|
| 21 | public oasis_unitget |
|---|
| 22 | public oasis_unitfree |
|---|
| 23 | public oasis_debug_enter |
|---|
| 24 | public oasis_debug_exit |
|---|
| 25 | public oasis_debug_note |
|---|
| 26 | public oasis_sys_sortC |
|---|
| 27 | public oasis_sys_sortI |
|---|
| 28 | public oasis_sys_sortIkey |
|---|
| 29 | |
|---|
| 30 | integer(ip_intwp_p),save :: minion = 1024 |
|---|
| 31 | integer(ip_intwp_p),save :: maxion = 9999 |
|---|
| 32 | integer(ip_intwp_p),parameter :: tree_delta = 2 |
|---|
| 33 | integer(ip_intwp_p),save :: tree_indent = 0 |
|---|
| 34 | |
|---|
| 35 | !-------------------------------------------------------------------- |
|---|
| 36 | CONTAINS |
|---|
| 37 | !-------------------------------------------------------------------- |
|---|
| 38 | |
|---|
| 39 | !-------------------------------------------------------------------- |
|---|
| 40 | |
|---|
| 41 | !> OASIS abort method, publically available to users |
|---|
| 42 | |
|---|
| 43 | SUBROUTINE oasis_abort(id_compid, cd_routine, cd_message, file, line, rcode) |
|---|
| 44 | |
|---|
| 45 | IMPLICIT NONE |
|---|
| 46 | !-------------------------------------------------------------------- |
|---|
| 47 | INTEGER(kind=ip_intwp_p),INTENT(in),optional :: id_compid !< component id |
|---|
| 48 | CHARACTER(len=*), INTENT(in),optional :: cd_routine !< string defining calling routine |
|---|
| 49 | CHARACTER(len=*), INTENT(in),optional :: cd_message !< error message string |
|---|
| 50 | CHARACTER(len=*), INTENT(in),optional :: file !< file called from |
|---|
| 51 | INTEGER,INTENT(in),optional :: line !< line in file called from |
|---|
| 52 | INTEGER,INTENT(in),optional :: rcode !< optional code to return to invoking environment |
|---|
| 53 | !-------------------------------------------------------------------- |
|---|
| 54 | INTEGER :: ierror, errcode |
|---|
| 55 | character(len=*),parameter :: subname = '(oasis_abort)' |
|---|
| 56 | !-------------------------------------------------------------------- |
|---|
| 57 | |
|---|
| 58 | if (present(id_compid)) & |
|---|
| 59 | WRITE (nulprt,*) subname,astr,'compid = ',id_compid |
|---|
| 60 | if (present(cd_routine)) & |
|---|
| 61 | WRITE (nulprt,*) subname,astr,'called by = ',trim(cd_routine) |
|---|
| 62 | if (present(cd_message)) & |
|---|
| 63 | WRITE (nulprt,*) subname,astr,'message = ',trim(cd_message) |
|---|
| 64 | if (present(file)) & |
|---|
| 65 | WRITE (nulprt,*) subname,astr,'file = ',trim(file) |
|---|
| 66 | if (present(line)) & |
|---|
| 67 | WRITE (nulprt,*) subname,astr,'line = ',line |
|---|
| 68 | IF (PRESENT(rcode)) THEN |
|---|
| 69 | errcode=rcode |
|---|
| 70 | WRITE (nulprt,*) subname,astr,'errcode = ',errcode |
|---|
| 71 | ELSE |
|---|
| 72 | errcode=1 |
|---|
| 73 | ENDIF |
|---|
| 74 | |
|---|
| 75 | WRITE (nulprt,*) subname,astr,'on model = ',trim(compnm) |
|---|
| 76 | WRITE (nulprt,*) subname,astr,'on global rank = ',mpi_rank_global |
|---|
| 77 | WRITE (nulprt,*) subname,astr,'on local rank = ',mpi_rank_local |
|---|
| 78 | WRITE (nulprt,*) subname,astr,'CALLING ABORT FROM OASIS LAYER NOW' |
|---|
| 79 | CALL oasis_flush(nulprt) |
|---|
| 80 | |
|---|
| 81 | WRITE (0,*) subname,astr,'CALLING ABORT FROM OASIS LAYER NOW' |
|---|
| 82 | WRITE (0,*) subname,astr,'See the log files in the run directory' |
|---|
| 83 | CALL oasis_flush(0) |
|---|
| 84 | |
|---|
| 85 | #if defined use_comm_MPI1 || defined use_comm_MPI2 |
|---|
| 86 | CALL MPI_ABORT (mpi_comm_global, errcode, ierror) |
|---|
| 87 | #endif |
|---|
| 88 | |
|---|
| 89 | STOP |
|---|
| 90 | |
|---|
| 91 | END SUBROUTINE oasis_abort |
|---|
| 92 | |
|---|
| 93 | !========================================================================== |
|---|
| 94 | |
|---|
| 95 | !> Flushes output to file |
|---|
| 96 | |
|---|
| 97 | SUBROUTINE oasis_flush(nu) |
|---|
| 98 | |
|---|
| 99 | IMPLICIT NONE |
|---|
| 100 | |
|---|
| 101 | !-------------------------------------------------------------------- |
|---|
| 102 | INTEGER(kind=ip_intwp_p),INTENT(in) :: nu !< unit number of file |
|---|
| 103 | !-------------------------------------------------------------------- |
|---|
| 104 | character(len=*),parameter :: subname = '(oasis_flush)' |
|---|
| 105 | !-------------------------------------------------------------------- |
|---|
| 106 | |
|---|
| 107 | CALL FLUSH(nu) |
|---|
| 108 | |
|---|
| 109 | END SUBROUTINE oasis_flush |
|---|
| 110 | |
|---|
| 111 | !========================================================================== |
|---|
| 112 | |
|---|
| 113 | !> Get a free unit number |
|---|
| 114 | |
|---|
| 115 | SUBROUTINE oasis_unitget(uio) |
|---|
| 116 | |
|---|
| 117 | IMPLICIT NONE |
|---|
| 118 | |
|---|
| 119 | !-------------------------------------------------------------------- |
|---|
| 120 | INTEGER(kind=ip_intwp_p),INTENT(out) :: uio !< unit number |
|---|
| 121 | !-------------------------------------------------------------------- |
|---|
| 122 | INTEGER(kind=ip_intwp_p) :: n1 ! search for unit number |
|---|
| 123 | logical :: found,l_open |
|---|
| 124 | character(len=*),parameter :: subname = '(oasis_unitget)' |
|---|
| 125 | !-------------------------------------------------------------------- |
|---|
| 126 | |
|---|
| 127 | ! start at maxion and decrement the unit numbers |
|---|
| 128 | n1 = maxion+1 |
|---|
| 129 | found = .false. |
|---|
| 130 | do while (n1 > minion .and. .not.found) |
|---|
| 131 | n1 = n1 - 1 |
|---|
| 132 | inquire(unit=n1,opened=l_open) |
|---|
| 133 | if(.not.l_open) found=.true. |
|---|
| 134 | if (found .and. OASIS_debug >= 2) write(nulprt,*) subname,n1 |
|---|
| 135 | enddo |
|---|
| 136 | |
|---|
| 137 | if (.not.found) then |
|---|
| 138 | write(nulprt,*) subname,estr,'no unit number available ' |
|---|
| 139 | write(nulprt,*) subname,estr,'min/max units checked = ',minion,maxion |
|---|
| 140 | call oasis_abort(file=__FILE__,line=__LINE__) |
|---|
| 141 | endif |
|---|
| 142 | |
|---|
| 143 | uio = n1 |
|---|
| 144 | |
|---|
| 145 | END SUBROUTINE oasis_unitget |
|---|
| 146 | |
|---|
| 147 | !========================================================================== |
|---|
| 148 | |
|---|
| 149 | !> Set the minimum unit number allowed |
|---|
| 150 | |
|---|
| 151 | SUBROUTINE oasis_unitsetmin(uio) |
|---|
| 152 | |
|---|
| 153 | IMPLICIT NONE |
|---|
| 154 | |
|---|
| 155 | !-------------------------------------------------------------------- |
|---|
| 156 | INTEGER(kind=ip_intwp_p),INTENT(in) :: uio !< unit number |
|---|
| 157 | !-------------------------------------------------------------------- |
|---|
| 158 | character(len=*),parameter :: subname = '(oasis_unitsetmin)' |
|---|
| 159 | !-------------------------------------------------------------------- |
|---|
| 160 | |
|---|
| 161 | minion = uio |
|---|
| 162 | if (OASIS_debug >= 20) write(nulprt,*) subname,minion |
|---|
| 163 | |
|---|
| 164 | END SUBROUTINE oasis_unitsetmin |
|---|
| 165 | |
|---|
| 166 | !========================================================================== |
|---|
| 167 | |
|---|
| 168 | !> Set the maximum unit number allowed |
|---|
| 169 | |
|---|
| 170 | SUBROUTINE oasis_unitsetmax(uio) |
|---|
| 171 | |
|---|
| 172 | IMPLICIT NONE |
|---|
| 173 | |
|---|
| 174 | !-------------------------------------------------------------------- |
|---|
| 175 | INTEGER(kind=ip_intwp_p),INTENT(in) :: uio !< unit number |
|---|
| 176 | !-------------------------------------------------------------------- |
|---|
| 177 | character(len=*),parameter :: subname = '(oasis_unitsetmax)' |
|---|
| 178 | !-------------------------------------------------------------------- |
|---|
| 179 | |
|---|
| 180 | maxion = uio |
|---|
| 181 | if (OASIS_debug >= 20) write(nulprt,*) subname,maxion |
|---|
| 182 | |
|---|
| 183 | END SUBROUTINE oasis_unitsetmax |
|---|
| 184 | |
|---|
| 185 | !========================================================================== |
|---|
| 186 | |
|---|
| 187 | !> Release a unit number for reuse |
|---|
| 188 | |
|---|
| 189 | SUBROUTINE oasis_unitfree(uio) |
|---|
| 190 | |
|---|
| 191 | IMPLICIT NONE |
|---|
| 192 | |
|---|
| 193 | !-------------------------------------------------------------------- |
|---|
| 194 | INTEGER(kind=ip_intwp_p),INTENT(in) :: uio !< unit number |
|---|
| 195 | !-------------------------------------------------------------------- |
|---|
| 196 | character(len=*),parameter :: subname = '(oasis_unitfree)' |
|---|
| 197 | !-------------------------------------------------------------------- |
|---|
| 198 | |
|---|
| 199 | ! tcraig, this is a no-op since we are no longer tracking units |
|---|
| 200 | ! explicitly. instead, we are searching for free units and using them. |
|---|
| 201 | ! either a unit number is open or closed and we'll check that explicitly |
|---|
| 202 | |
|---|
| 203 | if (OASIS_debug >= 20) write(nulprt,*) subname,uio |
|---|
| 204 | |
|---|
| 205 | END SUBROUTINE oasis_unitfree |
|---|
| 206 | |
|---|
| 207 | !========================================================================= |
|---|
| 208 | !========================================================================== |
|---|
| 209 | |
|---|
| 210 | !> Used when a subroutine is entered, write info to log file at some debug level |
|---|
| 211 | |
|---|
| 212 | SUBROUTINE oasis_debug_enter(string) |
|---|
| 213 | |
|---|
| 214 | IMPLICIT NONE |
|---|
| 215 | |
|---|
| 216 | !-------------------------------------------------------------------- |
|---|
| 217 | CHARACTER(len=*), INTENT(in) :: string !< name of the subroutine |
|---|
| 218 | |
|---|
| 219 | character(len=*),parameter :: subname = '(oasis_debug_enter)' |
|---|
| 220 | CHARACTER(len=1), pointer :: ch_blank(:) |
|---|
| 221 | CHARACTER(len=500) :: tree_enter |
|---|
| 222 | |
|---|
| 223 | if (OASIS_debug >= 10) then |
|---|
| 224 | ALLOCATE (ch_blank(tree_indent)) |
|---|
| 225 | ch_blank='-' |
|---|
| 226 | tree_enter='-- ENTER '//TRIM(string) |
|---|
| 227 | WRITE(nulprt,*) ch_blank,TRIM(tree_enter) |
|---|
| 228 | tree_indent = tree_indent + tree_delta |
|---|
| 229 | DEALLOCATE (ch_blank) |
|---|
| 230 | CALL oasis_flush(nulprt) |
|---|
| 231 | endif |
|---|
| 232 | |
|---|
| 233 | END SUBROUTINE oasis_debug_enter |
|---|
| 234 | |
|---|
| 235 | !========================================================================== |
|---|
| 236 | |
|---|
| 237 | !> Used when a subroutine is exited, write info to log file at some debug level |
|---|
| 238 | |
|---|
| 239 | SUBROUTINE oasis_debug_exit(string) |
|---|
| 240 | |
|---|
| 241 | IMPLICIT NONE |
|---|
| 242 | |
|---|
| 243 | !-------------------------------------------------------------------- |
|---|
| 244 | CHARACTER(len=*), INTENT(in) :: string !< name of subroutine |
|---|
| 245 | |
|---|
| 246 | character(len=*),parameter :: subname = '(oasis_debug_exit)' |
|---|
| 247 | CHARACTER(len=1), pointer :: ch_blank(:) |
|---|
| 248 | CHARACTER(len=500) :: tree_exit |
|---|
| 249 | |
|---|
| 250 | IF (OASIS_debug >= 10) THEN |
|---|
| 251 | tree_indent = MAX(0,tree_indent - tree_delta) |
|---|
| 252 | ALLOCATE (ch_blank(tree_indent)) |
|---|
| 253 | ch_blank='-' |
|---|
| 254 | tree_exit='-- EXIT '//TRIM(string) |
|---|
| 255 | WRITE(nulprt,*) ch_blank,TRIM(tree_exit) |
|---|
| 256 | DEALLOCATE (ch_blank) |
|---|
| 257 | CALL oasis_flush(nulprt) |
|---|
| 258 | ENDIF |
|---|
| 259 | |
|---|
| 260 | END SUBROUTINE oasis_debug_exit |
|---|
| 261 | |
|---|
| 262 | !========================================================================== |
|---|
| 263 | |
|---|
| 264 | !> Used to write information from a subroutine, write info to log file at some debug level |
|---|
| 265 | |
|---|
| 266 | SUBROUTINE oasis_debug_note(string) |
|---|
| 267 | |
|---|
| 268 | IMPLICIT NONE |
|---|
| 269 | |
|---|
| 270 | !-------------------------------------------------------------------- |
|---|
| 271 | CHARACTER(len=*), INTENT(in) :: string !< string to write |
|---|
| 272 | |
|---|
| 273 | character(len=*),parameter :: subname = '(oasis_debug_note)' |
|---|
| 274 | CHARACTER(len=1), pointer :: ch_blank(:) |
|---|
| 275 | CHARACTER(len=500) :: tree_note |
|---|
| 276 | |
|---|
| 277 | if (OASIS_debug >= 12) then |
|---|
| 278 | ALLOCATE (ch_blank(tree_indent)) |
|---|
| 279 | ch_blank='-' |
|---|
| 280 | tree_note='-- NOTE '//TRIM(string) |
|---|
| 281 | WRITE(nulprt,*) ch_blank,TRIM(tree_note) |
|---|
| 282 | DEALLOCATE(ch_blank) |
|---|
| 283 | call oasis_flush(nulprt) |
|---|
| 284 | endif |
|---|
| 285 | |
|---|
| 286 | END SUBROUTINE oasis_debug_note |
|---|
| 287 | |
|---|
| 288 | !========================================================================== |
|---|
| 289 | |
|---|
| 290 | !> Sort a character array and compute a sort key. |
|---|
| 291 | |
|---|
| 292 | ! !DESCRIPTION: |
|---|
| 293 | ! Sort a character array and the associated array(s) based on a |
|---|
| 294 | ! reasonably fast sort algorithm |
|---|
| 295 | |
|---|
| 296 | ! !INTERFACE: ----------------------------------------------------------------- |
|---|
| 297 | |
|---|
| 298 | subroutine oasis_sys_sortC(num, fld, sortkey) |
|---|
| 299 | |
|---|
| 300 | ! !USES: |
|---|
| 301 | |
|---|
| 302 | !--- local kinds --- |
|---|
| 303 | integer,parameter :: R8 = ip_double_p |
|---|
| 304 | integer,parameter :: IN = ip_i4_p |
|---|
| 305 | integer,parameter :: CL = ic_lvar |
|---|
| 306 | |
|---|
| 307 | ! !INPUT/OUTPUT PARAMETERS: |
|---|
| 308 | |
|---|
| 309 | integer(IN), intent(in) :: num !< size of array |
|---|
| 310 | character(len=CL),intent(inout) :: fld(:) !< sort field |
|---|
| 311 | integer(IN) ,intent(inout) :: sortkey(:) !< sort key |
|---|
| 312 | |
|---|
| 313 | ! !EOP |
|---|
| 314 | |
|---|
| 315 | !--- local --- |
|---|
| 316 | integer(IN) :: n1,n2 |
|---|
| 317 | character(CL), pointer :: tmpfld(:) |
|---|
| 318 | integer(IN) , pointer :: tmpkey(:) |
|---|
| 319 | |
|---|
| 320 | !--- formats --- |
|---|
| 321 | character(*),parameter :: subName = '(oasis_sys_sortC) ' |
|---|
| 322 | |
|---|
| 323 | !------------------------------------------------------------------------------- |
|---|
| 324 | ! |
|---|
| 325 | !------------------------------------------------------------------------------- |
|---|
| 326 | |
|---|
| 327 | ! call oasis_debug_enter(subname) |
|---|
| 328 | |
|---|
| 329 | allocate(tmpfld((num+1)/2)) |
|---|
| 330 | allocate(tmpkey((num+1)/2)) |
|---|
| 331 | call oasis_sys_mergesortC(num,fld,tmpfld,sortkey,tmpkey) |
|---|
| 332 | deallocate(tmpfld) |
|---|
| 333 | deallocate(tmpkey) |
|---|
| 334 | |
|---|
| 335 | ! call oasis_debug_exit(subname) |
|---|
| 336 | |
|---|
| 337 | end subroutine oasis_sys_sortC |
|---|
| 338 | |
|---|
| 339 | !========================================================================== |
|---|
| 340 | |
|---|
| 341 | !> Sort a integer array and compute a sort key. |
|---|
| 342 | |
|---|
| 343 | ! !DESCRIPTION: |
|---|
| 344 | ! Sort a character array and the associated array(s) based on a |
|---|
| 345 | ! reasonably fast sort algorithm |
|---|
| 346 | |
|---|
| 347 | ! !INTERFACE: ----------------------------------------------------------------- |
|---|
| 348 | |
|---|
| 349 | subroutine oasis_sys_sortI(num, fld, sortkey) |
|---|
| 350 | |
|---|
| 351 | ! !USES: |
|---|
| 352 | |
|---|
| 353 | !--- local kinds --- |
|---|
| 354 | integer,parameter :: R8 = ip_double_p |
|---|
| 355 | integer,parameter :: IN = ip_i4_p |
|---|
| 356 | integer,parameter :: CL = ic_lvar |
|---|
| 357 | |
|---|
| 358 | ! !INPUT/OUTPUT PARAMETERS: |
|---|
| 359 | |
|---|
| 360 | integer(IN),intent(in) :: num !< size of array |
|---|
| 361 | integer(IN),intent(inout) :: fld(:) !< sort field |
|---|
| 362 | integer(IN),intent(inout) :: sortkey(:) !< sort key |
|---|
| 363 | |
|---|
| 364 | ! !EOP |
|---|
| 365 | |
|---|
| 366 | !--- local --- |
|---|
| 367 | integer(IN) :: n1,n2 |
|---|
| 368 | integer(IN), pointer :: tmpfld(:) |
|---|
| 369 | integer(IN), pointer :: tmpkey(:) |
|---|
| 370 | |
|---|
| 371 | !--- formats --- |
|---|
| 372 | character(*),parameter :: subName = '(oasis_sys_sortI) ' |
|---|
| 373 | |
|---|
| 374 | !------------------------------------------------------------------------------- |
|---|
| 375 | ! |
|---|
| 376 | !------------------------------------------------------------------------------- |
|---|
| 377 | |
|---|
| 378 | ! call oasis_debug_enter(subname) |
|---|
| 379 | |
|---|
| 380 | allocate(tmpfld((num+1)/2)) |
|---|
| 381 | allocate(tmpkey((num+1)/2)) |
|---|
| 382 | call oasis_sys_mergesortI(num,fld,tmpfld,sortkey,tmpkey) |
|---|
| 383 | deallocate(tmpfld) |
|---|
| 384 | deallocate(tmpkey) |
|---|
| 385 | |
|---|
| 386 | ! call oasis_debug_exit(subname) |
|---|
| 387 | |
|---|
| 388 | end subroutine oasis_sys_sortI |
|---|
| 389 | |
|---|
| 390 | !------------------------------------------------------------ |
|---|
| 391 | |
|---|
| 392 | !> Sort an integer array using a sort key. |
|---|
| 393 | |
|---|
| 394 | ! !DESCRIPTION: |
|---|
| 395 | ! Rearrange and integer array based on an input sortkey |
|---|
| 396 | |
|---|
| 397 | ! !INTERFACE: ----------------------------------------------------------------- |
|---|
| 398 | |
|---|
| 399 | subroutine oasis_sys_sortIkey(num, arr, sortkey) |
|---|
| 400 | |
|---|
| 401 | ! !USES: |
|---|
| 402 | |
|---|
| 403 | !--- local kinds --- |
|---|
| 404 | integer,parameter :: R8 = ip_double_p |
|---|
| 405 | integer,parameter :: IN = ip_i4_p |
|---|
| 406 | integer,parameter :: CL = ic_lvar |
|---|
| 407 | |
|---|
| 408 | ! !INPUT/OUTPUT PARAMETERS: |
|---|
| 409 | |
|---|
| 410 | integer(IN),intent(in) :: num !< size of array |
|---|
| 411 | integer(IN),intent(inout) :: arr(:) !< field to sort |
|---|
| 412 | integer(IN),intent(in) :: sortkey(:) !< sort key |
|---|
| 413 | |
|---|
| 414 | ! !EOP |
|---|
| 415 | |
|---|
| 416 | !--- local --- |
|---|
| 417 | integer(IN) :: n1,n2 |
|---|
| 418 | integer(IN), pointer :: tmparr(:) |
|---|
| 419 | |
|---|
| 420 | !--- formats --- |
|---|
| 421 | character(*),parameter :: subName = '(oasis_sys_sortIkey) ' |
|---|
| 422 | |
|---|
| 423 | !------------------------------------------------------------------------------- |
|---|
| 424 | ! |
|---|
| 425 | !------------------------------------------------------------------------------- |
|---|
| 426 | |
|---|
| 427 | ! call oasis_debug_enter(subname) |
|---|
| 428 | |
|---|
| 429 | if (num /= size(arr) .or. num /= size(sortkey)) then |
|---|
| 430 | WRITE(nulprt,*) subname,estr,'on size of input arrays :',num,size(arr),size(sortkey) |
|---|
| 431 | call oasis_abort(file=__FILE__,line=__LINE__) |
|---|
| 432 | endif |
|---|
| 433 | |
|---|
| 434 | allocate(tmparr(num)) |
|---|
| 435 | tmparr(1:num) = arr(1:num) |
|---|
| 436 | do n1 = 1,num |
|---|
| 437 | arr(n1) = tmparr(sortkey(n1)) |
|---|
| 438 | enddo |
|---|
| 439 | deallocate(tmparr) |
|---|
| 440 | |
|---|
| 441 | ! call oasis_debug_exit(subname) |
|---|
| 442 | |
|---|
| 443 | end subroutine oasis_sys_sortIkey |
|---|
| 444 | |
|---|
| 445 | !========================================================================== |
|---|
| 446 | !========================================================================== |
|---|
| 447 | |
|---|
| 448 | !> Generic oasis_sys_mergesortC routine for character strings |
|---|
| 449 | |
|---|
| 450 | recursive subroutine oasis_sys_mergesortC(N,A,T,S,Z) |
|---|
| 451 | |
|---|
| 452 | !--- local kinds --- |
|---|
| 453 | integer,parameter :: R8 = ip_double_p |
|---|
| 454 | integer,parameter :: IN = ip_i4_p |
|---|
| 455 | integer,parameter :: CL = ic_lvar |
|---|
| 456 | |
|---|
| 457 | integer , intent(in) :: N ! size |
|---|
| 458 | character(CL), dimension(N) , intent(inout) :: A ! data to sort |
|---|
| 459 | character(CL), dimension((N+1)/2), intent(out) :: T ! data tmp |
|---|
| 460 | integer(IN) , dimension(N) , intent(inout) :: S ! sortkey |
|---|
| 461 | integer(IN) , dimension((N+1)/2), intent(out) :: Z ! sortkey tmp |
|---|
| 462 | |
|---|
| 463 | integer :: NA,NB |
|---|
| 464 | character(CL) :: V |
|---|
| 465 | integer(IN) :: Y |
|---|
| 466 | character(*),parameter :: subName = '(oasis_sys_mergesortC) ' |
|---|
| 467 | |
|---|
| 468 | ! write(nulprt,*) subname//' N = ',N |
|---|
| 469 | |
|---|
| 470 | if (N < 2) return |
|---|
| 471 | if (N == 2) then |
|---|
| 472 | if (A(1) > A(2)) then |
|---|
| 473 | V = A(1) |
|---|
| 474 | Y = S(1) |
|---|
| 475 | A(1) = A(2) |
|---|
| 476 | S(1) = S(2) |
|---|
| 477 | A(2) = V |
|---|
| 478 | S(2) = Y |
|---|
| 479 | endif |
|---|
| 480 | return |
|---|
| 481 | endif |
|---|
| 482 | NA=(N+1)/2 |
|---|
| 483 | NB=N-NA |
|---|
| 484 | |
|---|
| 485 | call oasis_sys_mergesortC(NA,A,T,S,Z) |
|---|
| 486 | call oasis_sys_mergesortC(NB,A(NA+1),T,S(NA+1),Z) |
|---|
| 487 | |
|---|
| 488 | if (A(NA) > A(NA+1)) then |
|---|
| 489 | T(1:NA)=A(1:NA) |
|---|
| 490 | Z(1:NA)=S(1:NA) |
|---|
| 491 | call oasis_sys_mergeC(T,Z,NA,A(NA+1),S(NA+1),NB,A,S,N) |
|---|
| 492 | endif |
|---|
| 493 | return |
|---|
| 494 | |
|---|
| 495 | end subroutine oasis_sys_mergesortC |
|---|
| 496 | |
|---|
| 497 | !========================================================================== |
|---|
| 498 | |
|---|
| 499 | !> Merge routine needed for mergesortC for character strings |
|---|
| 500 | |
|---|
| 501 | subroutine oasis_sys_mergeC(A,X,NA,B,Y,NB,C,Z,NC) |
|---|
| 502 | |
|---|
| 503 | !--- local kinds --- |
|---|
| 504 | integer,parameter :: R8 = ip_double_p |
|---|
| 505 | integer,parameter :: IN = ip_i4_p |
|---|
| 506 | integer,parameter :: CL = ic_lvar |
|---|
| 507 | |
|---|
| 508 | integer, intent(in) :: NA,NB,NC ! Normal usage: NA+NB = NC |
|---|
| 509 | character(CL), intent(inout) :: A(NA) ! B overlays C(NA+1:NC) |
|---|
| 510 | integer(IN) , intent(inout) :: X(NA) ! B overlays C(NA+1:NC) |
|---|
| 511 | character(CL), intent(in) :: B(NB) |
|---|
| 512 | integer(IN) , intent(in) :: Y(NB) |
|---|
| 513 | character(CL), intent(inout) :: C(NC) |
|---|
| 514 | integer(IN) , intent(inout) :: Z(NC) |
|---|
| 515 | |
|---|
| 516 | integer :: I,J,K |
|---|
| 517 | character(*),parameter :: subName = '(oasis_sys_mergeC) ' |
|---|
| 518 | |
|---|
| 519 | ! write(nulprt,*) subname//' NA,NB,NC = ',NA,NB,NC |
|---|
| 520 | |
|---|
| 521 | I = 1; J = 1; K = 1; |
|---|
| 522 | do while(I <= NA .and. J <= NB) |
|---|
| 523 | if (A(I) <= B(J)) then |
|---|
| 524 | C(K) = A(I) |
|---|
| 525 | Z(K) = X(I) |
|---|
| 526 | I = I+1 |
|---|
| 527 | else |
|---|
| 528 | C(K) = B(J) |
|---|
| 529 | Z(K) = Y(J) |
|---|
| 530 | J = J+1 |
|---|
| 531 | endif |
|---|
| 532 | K = K + 1 |
|---|
| 533 | enddo |
|---|
| 534 | do while (I <= NA) |
|---|
| 535 | C(K) = A(I) |
|---|
| 536 | Z(K) = X(I) |
|---|
| 537 | I = I + 1 |
|---|
| 538 | K = K + 1 |
|---|
| 539 | enddo |
|---|
| 540 | return |
|---|
| 541 | |
|---|
| 542 | end subroutine oasis_sys_mergeC |
|---|
| 543 | |
|---|
| 544 | !========================================================================== |
|---|
| 545 | |
|---|
| 546 | !> Generic oasis_sys_mergesortI routine for an integer array |
|---|
| 547 | |
|---|
| 548 | recursive subroutine oasis_sys_mergesortI(N,A,T,S,Z) |
|---|
| 549 | |
|---|
| 550 | !--- local kinds --- |
|---|
| 551 | integer,parameter :: R8 = ip_double_p |
|---|
| 552 | integer,parameter :: IN = ip_i4_p |
|---|
| 553 | integer,parameter :: CL = ic_lvar |
|---|
| 554 | |
|---|
| 555 | integer , intent(in) :: N ! size |
|---|
| 556 | integer(IN), dimension(N) , intent(inout) :: A ! data to sort |
|---|
| 557 | integer(IN), dimension((N+1)/2), intent(out) :: T ! data tmp |
|---|
| 558 | integer(IN), dimension(N) , intent(inout) :: S ! sortkey |
|---|
| 559 | integer(IN), dimension((N+1)/2), intent(out) :: Z ! sortkey tmp |
|---|
| 560 | |
|---|
| 561 | integer :: NA,NB |
|---|
| 562 | integer(IN) :: V |
|---|
| 563 | integer(IN) :: Y |
|---|
| 564 | character(*),parameter :: subName = '(oasis_sys_mergesortI) ' |
|---|
| 565 | |
|---|
| 566 | ! write(nulprt,*) subname//' N = ',N |
|---|
| 567 | |
|---|
| 568 | if (N < 2) return |
|---|
| 569 | if (N == 2) then |
|---|
| 570 | if (A(1) > A(2)) then |
|---|
| 571 | V = A(1) |
|---|
| 572 | Y = S(1) |
|---|
| 573 | A(1) = A(2) |
|---|
| 574 | S(1) = S(2) |
|---|
| 575 | A(2) = V |
|---|
| 576 | S(2) = Y |
|---|
| 577 | endif |
|---|
| 578 | return |
|---|
| 579 | endif |
|---|
| 580 | NA=(N+1)/2 |
|---|
| 581 | NB=N-NA |
|---|
| 582 | |
|---|
| 583 | call oasis_sys_mergesortI(NA,A,T,S,Z) |
|---|
| 584 | call oasis_sys_mergesortI(NB,A(NA+1),T,S(NA+1),Z) |
|---|
| 585 | |
|---|
| 586 | if (A(NA) > A(NA+1)) then |
|---|
| 587 | T(1:NA)=A(1:NA) |
|---|
| 588 | Z(1:NA)=S(1:NA) |
|---|
| 589 | call oasis_sys_mergeI(T,Z,NA,A(NA+1),S(NA+1),NB,A,S,N) |
|---|
| 590 | endif |
|---|
| 591 | return |
|---|
| 592 | |
|---|
| 593 | end subroutine oasis_sys_mergesortI |
|---|
| 594 | |
|---|
| 595 | !========================================================================== |
|---|
| 596 | |
|---|
| 597 | !> Merge routine needed for mergesortI for integer array |
|---|
| 598 | |
|---|
| 599 | subroutine oasis_sys_mergeI(A,X,NA,B,Y,NB,C,Z,NC) |
|---|
| 600 | |
|---|
| 601 | !--- local kinds --- |
|---|
| 602 | integer,parameter :: R8 = ip_double_p |
|---|
| 603 | integer,parameter :: IN = ip_i4_p |
|---|
| 604 | integer,parameter :: CL = ic_lvar |
|---|
| 605 | |
|---|
| 606 | integer, intent(in) :: NA,NB,NC ! Normal usage: NA+NB = NC |
|---|
| 607 | integer(IN), intent(inout) :: A(NA) ! B overlays C(NA+1:NC) |
|---|
| 608 | integer(IN), intent(inout) :: X(NA) ! B overlays C(NA+1:NC) |
|---|
| 609 | integer(IN), intent(in) :: B(NB) |
|---|
| 610 | integer(IN), intent(in) :: Y(NB) |
|---|
| 611 | integer(IN), intent(inout) :: C(NC) |
|---|
| 612 | integer(IN), intent(inout) :: Z(NC) |
|---|
| 613 | |
|---|
| 614 | integer :: I,J,K |
|---|
| 615 | character(*),parameter :: subName = '(oasis_sys_mergeI) ' |
|---|
| 616 | |
|---|
| 617 | ! write(nulprt,*) subname//' NA,NB,NC = ',NA,NB,NC |
|---|
| 618 | |
|---|
| 619 | I = 1; J = 1; K = 1; |
|---|
| 620 | do while(I <= NA .and. J <= NB) |
|---|
| 621 | if (A(I) <= B(J)) then |
|---|
| 622 | C(K) = A(I) |
|---|
| 623 | Z(K) = X(I) |
|---|
| 624 | I = I+1 |
|---|
| 625 | else |
|---|
| 626 | C(K) = B(J) |
|---|
| 627 | Z(K) = Y(J) |
|---|
| 628 | J = J+1 |
|---|
| 629 | endif |
|---|
| 630 | K = K + 1 |
|---|
| 631 | enddo |
|---|
| 632 | do while (I <= NA) |
|---|
| 633 | C(K) = A(I) |
|---|
| 634 | Z(K) = X(I) |
|---|
| 635 | I = I + 1 |
|---|
| 636 | K = K + 1 |
|---|
| 637 | enddo |
|---|
| 638 | return |
|---|
| 639 | |
|---|
| 640 | end subroutine oasis_sys_mergeI |
|---|
| 641 | |
|---|
| 642 | !========================================================================== |
|---|
| 643 | |
|---|
| 644 | END MODULE mod_oasis_sys |
|---|
