Oasis3 4.0.2
|
00001 SUBROUTINE qlsort (prho, kto, kwg) 00002 C**** 00003 C ***************************** 00004 C * OASIS ROUTINE - LEVEL 3 * 00005 C * ------------- ------- * 00006 C ***************************** 00007 C 00008 C**** *qlsort* - Sort kwg numbers with adresses 00009 C 00010 C Purpose: 00011 C ------- 00012 C Given kwg real in prho, this routine sort them and 00013 C rearrange the array kto in the same way. 00014 C 00015 C N.B: The method is a trivial one. the first element is assumed 00016 C to be the smallest and then tested against the following 00017 C one. If an element is smallest a permutation is made, 00018 C and the testing goes on with the next elements. There 00019 C is no need to test again the elements previously tested 00020 C as they are known to be greater. At the end of the loop 00021 C the smallest is in first position, and we repeat the 00022 C the procedure with the array starting in position two 00023 C and so on. 00024 C 00025 C** Interface: 00026 C --------- 00027 C *CALL* *qlsort (prho, kto, kwg)* 00028 C 00029 C Input: 00030 C ----- 00031 C prho : array to be sorted 00032 C kto : array to be re-arranged as prho 00033 C kwg : size of prho and kto 00034 C 00035 C Output: 00036 C ------ 00037 C prho : the sorted array 00038 C kto : the re-arranged array 00039 C 00040 C Workspace: 00041 C --------- 00042 C None 00043 C 00044 C External: 00045 C -------- 00046 C None 00047 C 00048 C References: 00049 C ---------- 00050 C O. Thual, Simple ocean-atmosphere interpolation. 00051 C Part A: The method, EPICOA 0629 (1992) 00052 C Part B: Software implementation, EPICOA 0630 (1992) 00053 C See also OASIS manual (1995) 00054 C 00055 C History: 00056 C ------- 00057 C Version Programmer Date Description 00058 C ------- ---------- ---- ----------- 00059 C 1.1 O. Thual 93/04/15 created 00060 C 2.0 L. Terray 95/10/01 modified: new structure 00061 C 00062 C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 00063 C 00064 C* ---------------------------- Include files --------------------------- 00065 C 00066 USE mod_kinds_oasis 00067 USE mod_unit 00068 C 00069 C* ---------------------------- Argument declarations ------------------- 00070 C 00071 REAL (kind=ip_realwp_p) prho(kwg) 00072 INTEGER (kind=ip_intwp_p) kto(kwg) 00073 C 00074 C* ---------------------------- Poema verses ---------------------------- 00075 C 00076 C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 00077 C 00078 C* 1. Sorting algorithm 00079 C ----------------- 00080 C 00081 C* If kwg is equal to one no sorting is needed 00082 C 00083 IF (kwg .EQ. 1) RETURN 00084 C 00085 C* Loop on all the positions 00086 C 00087 ikwgm = kwg - 1 00088 DO 110 jwg = 1, ikwgm 00089 ijwgp = jwg + 1 00090 C 00091 C* Loop on the element following the position 00092 C 00093 DO 120 jnext = ijwgp, kwg 00094 zsmal = prho(jwg) 00095 zbig = prho(jnext) 00096 C 00097 C* Testing the smallness assumption 00098 C 00099 IF (zsmal .GT. zbig) THEN 00100 C 00101 C* Permutation of prho 00102 C 00103 prho(jnext) = zsmal 00104 prho(jwg) = zbig 00105 C 00106 C* Permutation of kto 00107 C 00108 ikbig = kto(jnext) 00109 kto(jnext) = kto(jwg) 00110 kto(jwg) = ikbig 00111 ENDIF 00112 120 CONTINUE 00113 110 CONTINUE 00114 C 00115 C* End of routine 00116 C 00117 RETURN 00118 END