[2893] | 1 | PROGRAM bufr2fb |
---|
| 2 | #ifdef HAS_BUFR |
---|
| 3 | USE toolspar_kind |
---|
| 4 | USE obs_fbm |
---|
| 5 | USE bufrdata |
---|
| 6 | USE convmerge |
---|
| 7 | IMPLICIT NONE |
---|
| 8 | ! |
---|
| 9 | ! Command line arguments for output file and input files |
---|
| 10 | ! |
---|
| 11 | #ifndef NOIARGCPROTO |
---|
| 12 | INTEGER,EXTERNAL :: iargc |
---|
| 13 | #endif |
---|
| 14 | INTEGER :: nargs |
---|
| 15 | CHARACTER(len=256) :: cdtsfilem, cdtsfile1, cduvfilem, cduvfile1 |
---|
| 16 | CHARACTER(len=256),ALLOCATABLE :: cdinfile(:) |
---|
| 17 | ! |
---|
| 18 | ! Input data |
---|
| 19 | ! |
---|
| 20 | TYPE(obfbdata), POINTER :: bufrtsm(:), bufrts1(:), bufruvm(:), bufruv1(:) |
---|
| 21 | INTEGER :: ninfiles |
---|
| 22 | INTEGER :: ntottsm, nmaxlevts, ntotts1 |
---|
| 23 | INTEGER :: ntotuvm, nmaxlevuv, ntotuv1 |
---|
| 24 | ! |
---|
| 25 | ! Loop variables |
---|
| 26 | ! |
---|
| 27 | INTEGER :: ia |
---|
| 28 | ! |
---|
| 29 | ! Get number of command line arguments |
---|
| 30 | ! |
---|
| 31 | nargs=IARGC() |
---|
| 32 | IF (nargs < 4) THEN |
---|
| 33 | WRITE(*,'(A)')'Usage:' |
---|
| 34 | WRITE(*,'(A)')'bufr2fb TS_outputfile_prof TS_outputfile_surf '//& |
---|
| 35 | & 'UV_outputfile_prof UV_outputfile_surf '//& |
---|
| 36 | & 'inputfile1 inputfile2 ...' |
---|
| 37 | CALL abort() |
---|
| 38 | ENDIF |
---|
| 39 | CALL getarg(1,cdtsfilem) |
---|
| 40 | CALL getarg(2,cdtsfile1) |
---|
| 41 | CALL getarg(3,cduvfilem) |
---|
| 42 | CALL getarg(4,cduvfile1) |
---|
| 43 | ! |
---|
| 44 | ! Get input data |
---|
| 45 | ! |
---|
| 46 | ALLOCATE( bufrtsm(MAX(nargs-4,1)) ) |
---|
| 47 | ALLOCATE( bufrts1(MAX(nargs-4,1)) ) |
---|
| 48 | ALLOCATE( bufruvm(MAX(nargs-4,1)) ) |
---|
| 49 | ALLOCATE( bufruv1(MAX(nargs-4,1)) ) |
---|
| 50 | ALLOCATE( cdinfile(MAX(nargs-4,1)) ) |
---|
| 51 | ntottsm = 0 |
---|
| 52 | ntotts1 = 0 |
---|
| 53 | ntotuvm = 0 |
---|
| 54 | ntotuv1 = 0 |
---|
| 55 | ninfiles = nargs - 4 |
---|
| 56 | DO ia=1,ninfiles |
---|
| 57 | CALL getarg( ia + 4, cdinfile(ia) ) |
---|
| 58 | CALL read_bufrfile( TRIM(cdinfile(ia)), & |
---|
| 59 | & bufrtsm(ia), bufrts1(ia), & |
---|
| 60 | & bufruvm(ia), bufruv1(ia) ) |
---|
| 61 | WRITE(*,'(2A)')'File = ',TRIM(cdinfile(ia)) |
---|
| 62 | WRITE(*,'(A,I9,A)')'has',bufrtsm(ia)%nobs,' TS profiles' |
---|
| 63 | WRITE(*,'(A,I9,A)')'and',bufruvm(ia)%nobs,' UV profiles' |
---|
| 64 | WRITE(*,'(A,I9,A)')'and',bufrts1(ia)%nobs,' TS single level' |
---|
| 65 | WRITE(*,'(A,I9,A)')'and',bufruv1(ia)%nobs,' UV single level' |
---|
| 66 | ntottsm = ntottsm + bufrtsm(ia)%nobs |
---|
| 67 | ntotuvm = ntotuvm + bufruvm(ia)%nobs |
---|
| 68 | ntotts1 = ntotts1 + bufrts1(ia)%nobs |
---|
| 69 | ntotuv1 = ntotuv1 + bufruv1(ia)%nobs |
---|
| 70 | ENDDO |
---|
| 71 | IF (ninfiles==0) THEN |
---|
| 72 | CALL init_obfbdata( bufrtsm(1) ) |
---|
| 73 | CALL alloc_obfbdata( bufrtsm(1), 2, 0, 1, 0, 1, .FALSE. ) |
---|
| 74 | bufrtsm(1)%cname(1) = 'POTM' |
---|
| 75 | bufrtsm(1)%cname(2) = 'PSAL' |
---|
| 76 | bufrtsm(1)%coblong(1) = 'Potential temperature' |
---|
| 77 | bufrtsm(1)%coblong(2) = 'Practical salinity' |
---|
| 78 | bufrtsm(1)%cobunit(1) = 'Degrees Celsius' |
---|
| 79 | bufrtsm(1)%cobunit(2) = 'PSU' |
---|
| 80 | bufrtsm(1)%cextname(1) = 'TEMP' |
---|
| 81 | bufrtsm(1)%cextlong(1) = 'Insitu temperature' |
---|
| 82 | bufrtsm(1)%cextunit(1) = 'Degrees Celsius' |
---|
| 83 | bufrtsm(1)%cdjuldref = '19500101000000' |
---|
| 84 | CALL init_obfbdata( bufrts1(1) ) |
---|
| 85 | CALL alloc_obfbdata( bufrts1(1), 2, 0, 1, 0, 1, .FALSE. ) |
---|
| 86 | bufrts1(1)%cname(1) = 'POTM' |
---|
| 87 | bufrts1(1)%cname(2) = 'PSAL' |
---|
| 88 | bufrts1(1)%coblong(1) = 'Potential temperature' |
---|
| 89 | bufrts1(1)%coblong(2) = 'Practical salinity' |
---|
| 90 | bufrts1(1)%cobunit(1) = 'Degrees Celsius' |
---|
| 91 | bufrts1(1)%cobunit(2) = 'PSU' |
---|
| 92 | bufrts1(1)%cextname(1) = 'TEMP' |
---|
| 93 | bufrts1(1)%cextlong(1) = 'Insitu temperature' |
---|
| 94 | bufrts1(1)%cextunit(1) = 'Degrees Celsius' |
---|
| 95 | bufrts1(1)%cdjuldref = '19500101000000' |
---|
| 96 | CALL init_obfbdata( bufruvm(1) ) |
---|
| 97 | CALL alloc_obfbdata( bufruvm(1), 2, 0, 1, 0, 0, .FALSE. ) |
---|
| 98 | bufruvm(1)%cname(1) = 'UVEL' |
---|
| 99 | bufruvm(1)%cname(2) = 'VVEL' |
---|
| 100 | bufruvm(1)%coblong(1) = 'Zonal current' |
---|
| 101 | bufruvm(1)%coblong(2) = 'Meridional current' |
---|
| 102 | bufruvm(1)%cobunit(1) = 'Meters per second' |
---|
| 103 | bufruvm(1)%cobunit(2) = 'Meters per second' |
---|
| 104 | bufruvm(1)%cdjuldref = '19500101000000' |
---|
| 105 | CALL init_obfbdata( bufruv1(1) ) |
---|
| 106 | CALL alloc_obfbdata( bufruv1(1), 2, 0, 1, 0, 0, .FALSE. ) |
---|
| 107 | bufruv1(1)%cname(1) = 'UVEL' |
---|
| 108 | bufruv1(1)%cname(2) = 'VVEL' |
---|
| 109 | bufruv1(1)%coblong(1) = 'Zonal current' |
---|
| 110 | bufruv1(1)%coblong(2) = 'Meridional current' |
---|
| 111 | bufruv1(1)%cobunit(1) = 'Meters per second' |
---|
| 112 | bufruv1(1)%cobunit(2) = 'Meters per second' |
---|
| 113 | bufruv1(1)%cdjuldref = '19500101000000' |
---|
| 114 | ENDIF |
---|
| 115 | WRITE(*,'(A,I8)') 'Total TS profiles : ',ntottsm |
---|
| 116 | WRITE(*,'(A,I8)') 'Total TS single : ',ntotts1 |
---|
| 117 | WRITE(*,'(A,I8)') 'Total UV profiles : ',ntotuvm |
---|
| 118 | WRITE(*,'(A,I8)') 'Total UV single : ',ntotuv1 |
---|
| 119 | ! |
---|
| 120 | ! Merge and output the data. |
---|
| 121 | ! |
---|
| 122 | IF (TRIM(cdtsfilem)/='none') THEN |
---|
| 123 | ! Convert insitu temperature to potential temperature using the model |
---|
| 124 | ! salinity if no potential temperature |
---|
| 125 | DO ia = 1, ninfiles |
---|
| 126 | call fbpotem( bufrtsm(ia) ) |
---|
| 127 | ENDDO |
---|
| 128 | CALL conv_fbmerge( TRIM(cdtsfilem), ninfiles, bufrtsm ) |
---|
| 129 | ENDIF |
---|
| 130 | IF (TRIM(cdtsfile1)/='none') THEN |
---|
| 131 | DO ia = 1, ninfiles |
---|
| 132 | call fbpotem( bufrts1(ia) ) |
---|
| 133 | ENDDO |
---|
| 134 | CALL conv_fbmerge( TRIM(cdtsfile1), ninfiles, bufrts1 ) |
---|
| 135 | ENDIF |
---|
| 136 | IF (TRIM(cduvfilem)/='none') THEN |
---|
| 137 | CALL conv_fbmerge( TRIM(cduvfilem), ninfiles, bufruvm ) |
---|
| 138 | ENDIF |
---|
| 139 | IF (TRIM(cduvfile1)/='none') THEN |
---|
| 140 | CALL conv_fbmerge( TRIM(cduvfile1), ninfiles, bufruv1 ) |
---|
| 141 | ENDIF |
---|
| 142 | |
---|
| 143 | CONTAINS |
---|
| 144 | |
---|
| 145 | #include "obs_conv.h90" |
---|
| 146 | |
---|
| 147 | SUBROUTINE fbpotem( fbdata ) |
---|
| 148 | |
---|
| 149 | ! Convert insitu temperature to potential temperature |
---|
| 150 | |
---|
| 151 | TYPE(obfbdata) :: fbdata |
---|
| 152 | REAL :: zpres |
---|
| 153 | INTEGER :: jo,jk |
---|
| 154 | |
---|
| 155 | DO jo = 1, fbdata%nobs |
---|
| 156 | IF ( fbdata%pphi(jo) < 9999.0 ) THEN |
---|
| 157 | DO jk = 1, fbdata%nlev |
---|
| 158 | IF ( ( fbdata%pob(jk,jo,1) >= 9999.0 ) .AND. & |
---|
| 159 | & ( fbdata%pdep(jk,jo) < 9999.0 ) .AND. & |
---|
| 160 | & ( fbdata%pob(jk,jo,2) < 9999.0 ) .AND. & |
---|
| 161 | & ( fbdata%pext(jk,jo,1) < 9999.0 ) ) THEN |
---|
| 162 | zpres = dep_to_p( REAL(fbdata%pdep(jk,jo),wp), & |
---|
| 163 | & REAL(fbdata%pphi(jo),wp) ) |
---|
| 164 | fbdata%pob(jk,jo,1) = potemp( & |
---|
| 165 | & REAL(fbdata%pob(jk,jo,2), wp), & |
---|
| 166 | & REAL(fbdata%pext(jk,jo,1), wp), & |
---|
| 167 | & REAL(zpres,wp), 0.0_wp ) |
---|
| 168 | ENDIF |
---|
| 169 | ENDDO |
---|
| 170 | ENDIF |
---|
| 171 | ENDDO |
---|
| 172 | |
---|
| 173 | END SUBROUTINE fbpotem |
---|
| 174 | |
---|
| 175 | #else |
---|
| 176 | |
---|
| 177 | WRITE(*,'(A)')'bufr2fb compiled without -DHAS_BUFR so '//& |
---|
| 178 | & 'running it is pointless' |
---|
| 179 | CALL abort |
---|
| 180 | |
---|
| 181 | #endif |
---|
| 182 | |
---|
| 183 | END PROGRAM bufr2fb |
---|