Changeset 15224 for NEMO/branches/UKMO/NEMO_4.0.4_generic_obs
- Timestamp:
- 2021-09-01T17:16:18+02:00 (3 years ago)
- Location:
- NEMO/branches/UKMO/NEMO_4.0.4_generic_obs/src/OCE/OBS
- Files:
-
- 1 deleted
- 4 edited
-
diaobs.F90 (modified) (3 diffs)
-
obs_profiles.F90 (deleted)
-
obs_profiles_def.F90 (modified) (30 diffs)
-
obs_read_prof.F90 (modified) (3 diffs)
-
obs_write.F90 (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/UKMO/NEMO_4.0.4_generic_obs/src/OCE/OBS/diaobs.F90
r15187 r15224 56 56 PUBLIC dia_obs ! Compute model equivalent to observations 57 57 PUBLIC dia_obs_wri ! Write model equivalent to observations 58 PUBLIC dia_obs_dealloc ! Deallocate dia_obs data59 58 PUBLIC calc_date ! Compute the date of a timestep 60 59 … … 217 216 CALL obs_prof_staend( sobsgroups(jgroup)%sprofdata, jvar ) 218 217 END DO 218 ! 219 IF ( sobsgroups(jgroup)%sprofdata%next > 0 ) THEN 220 CALL obs_prof_staend_ext( sobsgroups(jgroup)%sprofdata ) 221 ENDIF 219 222 ! 220 223 CALL obs_pre_prof( sobsgroups(jgroup)%sprofdata, & … … 713 716 END SUBROUTINE dia_obs_wri 714 717 715 SUBROUTINE dia_obs_dealloc716 IMPLICIT NONE717 !!----------------------------------------------------------------------718 !! *** ROUTINE dia_obs_dealloc ***719 !!720 !! ** Purpose : To deallocate data to enable the obs_oper online loop.721 !! Specifically: dia_obs_init --> dia_obs --> dia_obs_wri722 !!723 !! ** Method : Clean up various arrays left behind by the obs_oper.724 !!725 !! ** Action :726 !!727 !!----------------------------------------------------------------------728 ! obs_grid deallocation729 CALL obs_grid_deallocate730 731 !!! DEALLOC sdobsgroups/components?732 733 END SUBROUTINE dia_obs_dealloc734 735 718 SUBROUTINE calc_date( kstp, ddobs ) 736 719 !!---------------------------------------------------------------------- -
NEMO/branches/UKMO/NEMO_4.0.4_generic_obs/src/OCE/OBS/obs_profiles_def.F90
r15180 r15224 43 43 & obs_prof_alloc, & 44 44 & obs_prof_alloc_var, & 45 & obs_prof_alloc_ext, & 45 46 & obs_prof_dealloc, & 46 47 & obs_prof_compress, & 47 48 & obs_prof_decompress,& 48 & obs_prof_staend 49 & obs_prof_staend, & 50 & obs_prof_staend_ext 49 51 50 52 !! * Type definition for valid observations … … 86 88 87 89 END TYPE obs_prof_var 90 91 !! * Type definition for extra variables 92 93 TYPE obs_prof_ext 94 95 ! Arrays with size equal to the number of observations 96 97 INTEGER, POINTER, DIMENSION(:) :: & 98 & nepidx,& !: Profile number 99 & nelidx !: Level number in profile 100 101 REAL(KIND=wp), POINTER, DIMENSION(:,:) :: & 102 & eobs !: Profile data 103 104 INTEGER, POINTER, DIMENSION(:) :: & 105 & neind !: Source indices of temp. data in compressed data 106 107 END TYPE obs_prof_ext 88 108 89 109 !! * Type definition for profile observation type … … 128 148 129 149 INTEGER, POINTER, DIMENSION(:) :: & 130 & nvprot, & !: Local total number of profile Tdata131 & nvprotmpp !: Global total number of profile Tdata150 & nvprot, & !: Local total number of profile data 151 & nvprotmpp !: Global total number of profile data 132 152 133 153 ! Arrays with size equal to the number of profiles … … 160 180 & npvsta, & !: Start of each variable profile in full arrays 161 181 & npvend, & !: End of each variable profile in full arrays 162 & mi, & !: i-th grid coord. for interpolating to profile Tdata163 & mj, & !: j-th grid coord. for interpolating to profile Tdata182 & mi, & !: i-th grid coord. for interpolating to profile data 183 & mj, & !: j-th grid coord. for interpolating to profile data 164 184 & ivqc !: QC flags for all levels for a variable 165 185 … … 180 200 TYPE(obs_prof_var), POINTER, DIMENSION(:) :: var 181 201 182 REAL(KIND=wp), POINTER, DIMENSION(:,:) :: & 183 & vext !: Extra variables 202 ! Extra variables 203 204 TYPE(obs_prof_ext) :: vext 205 206 INTEGER :: nvprotext !: Local total number of extra variable profile data 207 208 INTEGER, POINTER, DIMENSION(:) :: & 209 & npvstaext, & !: Start of extra variable profiles in full arrays 210 & npvendext !: End of extra variable profiles in full arrays 184 211 185 212 ! Arrays with size equal to the number of time steps in the window … … 221 248 222 249 SUBROUTINE obs_prof_alloc( prof, kvar, kadd, kext, kprof, & 223 & ko3dt, k stp, kpi, kpj, kpk )250 & ko3dt, ke3dt, kstp, kpi, kpj, kpk ) 224 251 !!---------------------------------------------------------------------- 225 252 !! *** ROUTINE obs_prof_alloc *** … … 241 268 INTEGER, INTENT(IN), DIMENSION(kvar) :: & 242 269 & ko3dt ! Number of observations per variables 270 INTEGER, INTENT(IN) :: ke3dt ! Number of observations per extra variables 243 271 INTEGER, INTENT(IN) :: kstp ! Number of time steps 244 272 INTEGER, INTENT(IN) :: kpi ! Number of 3D grid points … … 362 390 363 391 DO jvar = 1, kvar 364 365 392 IF ( ko3dt(jvar) >= 0 ) THEN 366 393 CALL obs_prof_alloc_var( prof, jvar, kadd, ko3dt(jvar) ) 367 394 ENDIF 368 369 END DO 370 371 ! Allocate extra variables 372 ALLOCATE( & 373 & prof%vext(kprof,kext) & 374 & ) 395 END DO 396 397 ! Extra variables 398 399 IF ( kext > 0 ) THEN 400 prof%nvprotext = ke3dt 401 ALLOCATE( & 402 & prof%npvstaext(kprof), & 403 & prof%npvendext(kprof) ) 404 CALL obs_prof_alloc_ext( prof, kext, ke3dt ) 405 ELSE 406 prof%nvprotext = 0 407 ENDIF 375 408 376 409 ! Allocate arrays of size number of time step size … … 407 440 END DO 408 441 END DO 442 443 IF ( kext > 0 ) THEN 444 DO ji = 1, ke3dt 445 prof%vext%neind(ji) = ji 446 END DO 447 ENDIF 409 448 410 449 ! Set defaults for number of observations per time step … … 438 477 !!* Local variables 439 478 INTEGER :: & 440 & jvar 479 & jvar, & 480 & jext 441 481 442 482 ! Deallocate arrays of size number of profiles … … 479 519 480 520 DO jvar = 1, prof%nvar 481 482 521 IF ( prof%nvprot(jvar) >= 0 ) THEN 483 484 522 CALL obs_prof_dealloc_var( prof, jvar ) 485 486 523 ENDIF 487 488 524 END DO 489 525 … … 494 530 495 531 ! Deallocate extra variables 496 DEALLOCATE( & 497 & prof%vext & 498 & ) 532 IF ( prof%next > 0 ) THEN 533 DEALLOCATE( & 534 & prof%npvstaext, & 535 & prof%npvendext & 536 ) 537 CALL obs_prof_dealloc_ext( prof ) 538 ENDIF 499 539 500 540 ! Deallocate arrays of size number of time step size … … 541 581 & prof%cextunit & 542 582 ) 543 544 583 545 584 END SUBROUTINE obs_prof_dealloc … … 586 625 END SUBROUTINE obs_prof_alloc_var 587 626 627 588 628 SUBROUTINE obs_prof_dealloc_var( prof, kvar ) 589 629 590 630 !!---------------------------------------------------------------------- 591 !! *** ROUTINE obs_prof_ alloc_var ***631 !! *** ROUTINE obs_prof_dealloc_var *** 592 632 !! 593 !! ** Purpose : - Allocate data for variable data in profile arrays633 !! ** Purpose : - Deallocate data for variable data in profile arrays 594 634 !! 595 635 !! ** Method : - Fortran-90 dynamic arrays … … 598 638 !! ! 07-03 (K. Mogensen) Original code 599 639 !! * Arguments 600 TYPE(obs_prof), INTENT(INOUT) :: prof ! Profile data to be allocated640 TYPE(obs_prof), INTENT(INOUT) :: prof ! Profile data to be deallocated 601 641 INTEGER, INTENT(IN) :: kvar ! Variable number 602 642 … … 622 662 END SUBROUTINE obs_prof_dealloc_var 623 663 664 665 SUBROUTINE obs_prof_alloc_ext( prof, kext, kobs ) 666 667 !!---------------------------------------------------------------------- 668 !! *** ROUTINE obs_prof_alloc_ext *** 669 !! 670 !! ** Purpose : - Allocate data for extra variables in profile arrays 671 !! 672 !! ** Method : - Fortran-90 dynamic arrays 673 !! 674 !! History : 675 !! ! 07-03 (K. Mogensen) Original code 676 !! * Arguments 677 TYPE(obs_prof), INTENT(INOUT) :: prof ! Profile data to be allocated 678 INTEGER, INTENT(IN) :: kext ! Number of extra variables 679 INTEGER, INTENT(IN) :: kobs ! Number of observations 680 681 ALLOCATE( & 682 & prof%vext%nepidx(kobs), & 683 & prof%vext%nelidx(kobs), & 684 & prof%vext%neind(kobs), & 685 & prof%vext%eobs(kobs,kext) & 686 & ) 687 688 END SUBROUTINE obs_prof_alloc_ext 689 690 691 SUBROUTINE obs_prof_dealloc_ext( prof ) 692 693 !!---------------------------------------------------------------------- 694 !! *** ROUTINE obs_prof_dealloc_var *** 695 !! 696 !! ** Purpose : - Deallocate data for extra variables in profile arrays 697 !! 698 !! ** Method : - Fortran-90 dynamic arrays 699 !! 700 !! History : 701 !! ! 07-03 (K. Mogensen) Original code 702 !! * Arguments 703 TYPE(obs_prof), INTENT(INOUT) :: prof ! Profile data to be deallocated 704 705 DEALLOCATE( & 706 & prof%vext%nepidx, & 707 & prof%vext%nelidx, & 708 & prof%vext%eobs, & 709 & prof%vext%neind & 710 & ) 711 712 END SUBROUTINE obs_prof_dealloc_ext 713 714 624 715 SUBROUTINE obs_prof_compress( prof, newprof, lallocate, & 625 & kumout, lvalid, 716 & kumout, lvalid, lvvalid ) 626 717 !!---------------------------------------------------------------------- 627 718 !! *** ROUTINE obs_prof_compress *** … … 644 735 TYPE(obs_prof), INTENT(IN) :: prof ! Original profile 645 736 TYPE(obs_prof), INTENT(INOUT) :: newprof ! New profile with the copy of the data 646 LOGICAL :: lallocate! Allocate newprof data647 INTEGER, INTENT(IN) :: kumout! Fortran unit for messages737 LOGICAL, INTENT(IN) :: lallocate ! Allocate newprof data 738 INTEGER, INTENT(IN) :: kumout ! Fortran unit for messages 648 739 TYPE(obs_prof_valid), OPTIONAL, INTENT(in) :: & 649 740 & lvalid ! Valid profiles … … 655 746 INTEGER, DIMENSION(prof%nvar) :: & 656 747 & invpro 748 INTEGER :: invproext 657 749 INTEGER :: jvar 658 750 INTEGER :: jadd … … 668 760 LOGICAL :: lnonepresent 669 761 670 ! Check that either all or none of the masks are p ersent.762 ! Check that either all or none of the masks are present. 671 763 672 764 lallpresent = .FALSE. … … 688 780 inprof = 0 689 781 invpro(:) = 0 782 invproext = 0 690 783 DO ji = 1, prof%nprof 691 784 IF ( lvalid%luse(ji) ) THEN … … 697 790 END DO 698 791 END DO 792 IF ( prof%next > 0 ) THEN 793 DO jj = prof%npvstaext(ji), prof%npvendext(ji) 794 invproext = invproext + 1 795 END DO 796 ENDIF 699 797 ENDIF 700 798 END DO … … 702 800 inprof = prof%nprof 703 801 invpro(:) = prof%nvprot(:) 802 invproext = prof%nvprotext 704 803 ENDIF 705 804 … … 710 809 & prof%nadd, prof%next, & 711 810 & inprof, invpro, & 811 & invproext, & 712 812 & prof%nstp, prof%npi, & 713 813 & prof%npj, prof%npk ) … … 736 836 inprof = 0 737 837 invpro(:) = 0 738 739 newprof%npvsta(:,:) = 0 740 newprof%npvend(:,:) = -1 838 invproext = 0 839 840 newprof%npvsta(:,:) = 0 841 newprof%npvend(:,:) = -1 842 newprof%npvstaext(:) = 0 843 newprof%npvendext(:) = -1 741 844 742 845 ! Loop over source profiles … … 837 940 END DO 838 941 839 DO jext = 1, prof%next 840 newprof%vext(inprof,jext) = prof%vext(ji,jext) 841 END DO 942 IF ( prof%next > 0 ) THEN 943 944 ! Extra variables 945 946 lfirst = .TRUE. 947 948 DO jj = prof%npvstaext(ji), prof%npvendext(ji) 949 950 invproext = invproext + 1 951 952 ! Book keeping information 953 954 IF ( lfirst ) THEN 955 lfirst = .FALSE. 956 newprof%npvstaext(inprof) = invproext 957 ENDIF 958 newprof%npvendext(inprof) = invproext 959 960 ! Variable data 961 962 newprof%vext%nepidx(invproext) = prof%vext%nepidx(jj) 963 newprof%vext%nelidx(invproext) = prof%vext%nelidx(jj) 964 DO jext = 1, prof%next 965 newprof%vext%eobs(invproext,jext) = prof%vext%eobs(jj,jext) 966 END DO 967 968 ! nvind is the index of the original variable data 969 970 newprof%vext%neind(invproext) = jj 971 972 END DO 973 974 ENDIF 842 975 843 976 ENDIF … … 852 985 CALL obs_mpp_sum_integers ( newprof%nvprot, newprof%nvprotmpp,& 853 986 & prof%nvar ) 987 newprof%nvprotext = invproext 854 988 855 989 ! Set book keeping variables which do not depend on number of obs. … … 866 1000 newprof%cunit(:) = prof%cunit(:) 867 1001 newprof%cgrid(:) = prof%cgrid(:) 868 newprof%caddvars(:) = prof%caddvars(:)869 newprof%caddlong(: ) = prof%caddlong(:)870 newprof%caddunit(: ) = prof%caddunit(:)871 newprof%cextvars(:) = prof%cextvars(:)872 newprof%cextlong(:) = prof%cextlong(:)873 newprof%cextunit(:) = prof%cextunit(:)1002 newprof%caddvars(:) = prof%caddvars(:) 1003 newprof%caddlong(:,:) = prof%caddlong(:,:) 1004 newprof%caddunit(:,:) = prof%caddunit(:,:) 1005 newprof%cextvars(:) = prof%cextvars(:) 1006 newprof%cextlong(:) = prof%cextlong(:) 1007 newprof%cextunit(:) = prof%cextunit(:) 874 1008 875 1009 ! Deallocate temporary data … … 971 1105 END DO 972 1106 973 DO jext = 1, prof%next 974 oldprof%vext(jk,jext) = prof%vext(jj,jext) 975 END DO 1107 IF ( prof%next > 0 ) THEN 1108 1109 DO jj = prof%npvstaext(ji), prof%npvendext(ji) 1110 1111 jl = prof%vext%neind(jj) 1112 1113 oldprof%vext%nepidx(jl) = prof%vext%nepidx(jj) 1114 oldprof%vext%nelidx(jl) = prof%vext%nelidx(jj) 1115 DO jext = 1, prof%next 1116 oldprof%vext%eobs(jl,jext) = prof%vext%eobs(jj,jext) 1117 END DO 1118 1119 END DO 1120 1121 ENDIF 976 1122 977 1123 END DO … … 983 1129 END SUBROUTINE obs_prof_decompress 984 1130 1131 985 1132 SUBROUTINE obs_prof_staend( prof, kvarno ) 986 1133 !!---------------------------------------------------------------------- 987 !! *** ROUTINE obs_prof_ decompress***1134 !! *** ROUTINE obs_prof_staend *** 988 1135 !! 989 1136 !! ** Purpose : - Set npvsta and npvend of a variable within … … 1024 1171 1025 1172 END SUBROUTINE obs_prof_staend 1173 1174 1175 SUBROUTINE obs_prof_staend_ext( prof ) 1176 !!---------------------------------------------------------------------- 1177 !! *** ROUTINE obs_prof_staend_ext *** 1178 !! 1179 !! ** Purpose : - Set npvsta and npvend within 1180 !! an obs_prof_ext type 1181 !! 1182 !! ** Method : - Find the start and stop of a profile by searching 1183 !! through the data 1184 !! 1185 !! History : 1186 !! ! 07-04 (K. Mogensen) Original code 1187 !!---------------------------------------------------------------------- 1188 !! * Arguments 1189 TYPE(obs_prof),INTENT(INOUT) :: prof ! Profile data 1190 1191 !!* Local variables 1192 INTEGER :: ji 1193 INTEGER :: iprofno 1194 1195 !----------------------------------------------------------------------- 1196 ! Compute start and end bookkeeping arrays 1197 !----------------------------------------------------------------------- 1198 1199 prof%npvstaext(:) = prof%nvprotext + 1 1200 prof%npvendext(:) = -1 1201 DO ji = 1, prof%nvprotext 1202 iprofno = prof%vext%nepidx(ji) 1203 prof%npvstaext(iprofno) = & 1204 & MIN( ji, prof%npvstaext(iprofno) ) 1205 prof%npvendext(iprofno) = & 1206 & MAX( ji, prof%npvendext(iprofno) ) 1207 END DO 1208 1209 DO ji = 1, prof%nprof 1210 IF ( prof%npvstaext(ji) == ( prof%nvprotext + 1 ) ) & 1211 & prof%npvstaext(ji) = 0 1212 END DO 1213 1214 END SUBROUTINE obs_prof_staend_ext 1026 1215 1027 1216 END MODULE obs_profiles_def -
NEMO/branches/UKMO/NEMO_4.0.4_generic_obs/src/OCE/OBS/obs_read_prof.F90
r15187 r15224 613 613 ENDIF 614 614 CALL obs_prof_alloc( profdata, kvars, kadd+iadd, kextr+iextr, iprof, iv3dt, & 615 & kstp, jpi, jpj, jpk )615 & ip3dt, kstp, jpi, jpj, jpk ) 616 616 617 617 ! * Read obs/positions, QC, all variable and assign to profdata … … 765 765 & CYCLE 766 766 767 IF ( ldallatall) THEN767 IF ( ldallatall .OR. (iextr > 0) ) THEN 768 768 769 769 DO jvar = 1, kvars … … 857 857 ! Extra variables 858 858 IF ( iextr > 0 ) THEN 859 profdata%vext%nepidx(ip3dt) = iprof 860 profdata%vext%nelidx(ip3dt) = ij 859 861 DO jext = 1, iextr 860 profdata%vext (iprof,kextr+jext) = inpfiles(jj)%pext(ij,ji,jext)862 profdata%vext%eobs(ip3dt,kextr+jext) = inpfiles(jj)%pext(ij,ji,jext) 861 863 END DO 862 864 ENDIF -
NEMO/branches/UKMO/NEMO_4.0.4_generic_obs/src/OCE/OBS/obs_write.F90
r15187 r15224 222 222 END DO 223 223 ENDIF 224 ! MOVE OUTSIDE JVAR LOOP?225 IF (iext > 0) THEN226 DO je = 1, iext227 fbdata%pext(ik,jo,je) = &228 & profdata%vext(jk,pext%ipoint(je))229 END DO230 ENDIF231 224 END DO 232 225 END DO 226 IF (iext > 0) THEN 227 DO jk = profdata%npvstaext(jo), profdata%npvendext(jo) 228 ik = profdata%vext%nelidx(jk) 229 DO je = 1, iext 230 fbdata%pext(ik,jo,je) = & 231 & profdata%vext%eobs(jk,pext%ipoint(je)) 232 END DO 233 END DO 234 ENDIF 233 235 END DO 234 236
Note: See TracChangeset
for help on using the changeset viewer.
